libpoe-component-irc-perl-6.88+dfsg.orig/0000755000175000017500000000000012354017166017621 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/LICENSE0000644000175000017500000004406712353530642020637 0ustar gregoagregoaThis software is copyright (c) 2014 by Dennis Taylor, Chris Williams, and Hinrik Örn Sigurðsson. 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) 2014 by Dennis Taylor, Chris Williams, and Hinrik Örn Sigurðsson. 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) 2014 by Dennis Taylor, Chris Williams, and Hinrik Örn Sigurðsson. 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 libpoe-component-irc-perl-6.88+dfsg.orig/MANIFEST0000644000175000017500000001140112354017166020747 0ustar gregoagregoa# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.019. Changes LICENSE MANIFEST MANIFEST.SKIP META.json META.yml Makefile.PL README dist.ini examples/aimproxy.pl examples/dcctest.pl examples/dicebot.pl examples/eliza.pl examples/ircproxy.pl examples/logger.pl examples/moo.pl examples/rot13_multi.pl examples/simpleclient.pl examples/tinyurl.pl lib/POE/Component/IRC.pm lib/POE/Component/IRC/Common.pm lib/POE/Component/IRC/Constants.pm lib/POE/Component/IRC/Cookbook.pod lib/POE/Component/IRC/Cookbook/BasicBot.pod lib/POE/Component/IRC/Cookbook/Disconnecting.pod lib/POE/Component/IRC/Cookbook/Gtk2.pod lib/POE/Component/IRC/Cookbook/Hailo.pod lib/POE/Component/IRC/Cookbook/Reload.pod lib/POE/Component/IRC/Cookbook/Resolver.pod lib/POE/Component/IRC/Cookbook/Seen.pod lib/POE/Component/IRC/Cookbook/Translator.pod lib/POE/Component/IRC/Plugin.pm lib/POE/Component/IRC/Plugin/AutoJoin.pm lib/POE/Component/IRC/Plugin/BotAddressed.pm lib/POE/Component/IRC/Plugin/BotCommand.pm lib/POE/Component/IRC/Plugin/BotTraffic.pm lib/POE/Component/IRC/Plugin/CTCP.pm lib/POE/Component/IRC/Plugin/Connector.pm lib/POE/Component/IRC/Plugin/Console.pm lib/POE/Component/IRC/Plugin/CycleEmpty.pm lib/POE/Component/IRC/Plugin/DCC.pm lib/POE/Component/IRC/Plugin/FollowTail.pm lib/POE/Component/IRC/Plugin/ISupport.pm lib/POE/Component/IRC/Plugin/Logger.pm lib/POE/Component/IRC/Plugin/NickReclaim.pm lib/POE/Component/IRC/Plugin/NickServID.pm lib/POE/Component/IRC/Plugin/PlugMan.pm lib/POE/Component/IRC/Plugin/Proxy.pm lib/POE/Component/IRC/Plugin/Whois.pm lib/POE/Component/IRC/Projects.pod lib/POE/Component/IRC/Qnet.pm lib/POE/Component/IRC/Qnet/State.pm lib/POE/Component/IRC/State.pm lib/POE/Filter/IRC.pm lib/POE/Filter/IRC/Compat.pm t/01_base/01_compile.t t/01_base/02_filters.t t/01_base/04_pocosi.t t/02_behavior/01_public_methods.t t/02_behavior/02_connect.t t/02_behavior/03_socketerr.t t/02_behavior/04_ipv6.t t/02_behavior/05_resolver.t t/02_behavior/06_online.t t/02_behavior/07_subclass.t t/02_behavior/08_parent_session.t t/02_behavior/09_multiple.t t/02_behavior/10_signal.t t/02_behavior/11_multi_signal.t t/02_behavior/12_delays.t t/02_behavior/13_activity.t t/02_behavior/14_newline.t t/02_behavior/15_no_stacked_ctcp.t t/02_behavior/16_nonclosing_ctcp.t t/02_behavior/17_raw.t t/02_behavior/18_shutdown.t t/03_subclasses/01_state.t t/03_subclasses/02_qnet.t t/03_subclasses/03_qnet_state.t t/03_subclasses/04_netsplit.t t/03_subclasses/05_state_awaypoll.t t/03_subclasses/06_state_nick_sync.t t/04_plugins/01_ctcp/01_load.t t/04_plugins/01_ctcp/02_replies.t t/04_plugins/02_connector/01_load.t t/04_plugins/02_connector/02_reconnect.t t/04_plugins/03_botaddressed/01_load.t t/04_plugins/03_botaddressed/02_output.t t/04_plugins/04_bottraffic/01_load.t t/04_plugins/04_bottraffic/02_output.t t/04_plugins/05_isupport/01_load.t t/04_plugins/05_isupport/02_isupport.t t/04_plugins/06_plugman/01_load.t t/04_plugins/06_plugman/02_add.t t/04_plugins/06_plugman/03_irc_interface.t t/04_plugins/06_plugman/04_auth_sub.t t/04_plugins/07_console/01_load.t t/04_plugins/08_proxy/01_load.t t/04_plugins/08_proxy/02_connect.t t/04_plugins/09_nickreclaim/01_load.t t/04_plugins/09_nickreclaim/02_reclaim.t t/04_plugins/09_nickreclaim/03_immediate_change.t t/04_plugins/09_nickreclaim/04_immediate_quit.t t/04_plugins/10_followtail/01_load.t t/04_plugins/11_cycleempty/01_load.t t/04_plugins/11_cycleempty/02_cycle.t t/04_plugins/12_autojoin/01_load.t t/04_plugins/12_autojoin/02_join.t t/04_plugins/12_autojoin/03_banned.t t/04_plugins/12_autojoin/04_kicked.t t/04_plugins/12_autojoin/05_password.t t/04_plugins/12_autojoin/06_kick_ban_password.t t/04_plugins/13_botcommand/01_load.t t/04_plugins/13_botcommand/02_commands.t t/04_plugins/13_botcommand/03_options.t t/04_plugins/13_botcommand/04_help.t t/04_plugins/13_botcommand/05_auth_sub.t t/04_plugins/13_botcommand/06_prefix.t t/04_plugins/13_botcommand/07_bare_private.t t/04_plugins/13_botcommand/08_nonword.t t/04_plugins/14_logger/01_load.t t/04_plugins/14_logger/02_public.t t/04_plugins/14_logger/03_private.t t/04_plugins/14_logger/04_dcc_chat.t t/04_plugins/14_logger/05_log_sub.t t/04_plugins/15_nickservid/01_load.t t/04_plugins/16_whois/01_load.t t/04_plugins/16_whois/02_whois.t t/04_plugins/17_dcc/01_load.t t/04_plugins/17_dcc/02_timeout.t t/04_plugins/17_dcc/03_send.t t/04_plugins/17_dcc/04_send_spaces.t t/04_plugins/17_dcc/05_resume.t t/04_plugins/17_dcc/06_chat.t t/04_plugins/17_dcc/07_nat.t t/05_regression/01_dcc_chat_close.t t/inc/Crypt/PasswdMD5.pm t/inc/Net/Netmask.pm t/inc/POE/Component/IRC/Test/Plugin.pm t/inc/POE/Component/Server/IRC.pm t/inc/POE/Component/Server/IRC/Backend.pm t/inc/POE/Component/Server/IRC/Common.pm t/inc/POE/Component/Server/IRC/Plugin.pm t/inc/POE/Component/Server/IRC/Plugin/Auth.pm t/inc/POE/Component/Server/IRC/Plugin/OperServ.pm libpoe-component-irc-perl-6.88+dfsg.orig/Changes0000644000175000017500000021305112353530642021114 0ustar gregoagregoaRevision history for Perl extension POE::Component::IRC. 6.88 Sat Jun 28 13:14:00 BST 2014 - BotAddressed: Handle being addressed with a prefixed @ or % 6.87 Sat Jun 21 15:08:32 BST 2014 - Believe have resolved issues with online test 6.86 Fri Jun 20 11:12:06 BST 2014 - Added more diagnostics to the online test 6.85 Thu Jun 19 10:19:07 BST 2014 - Added some diagnostics output to the online test 6.84 Tue Jun 17 10:45:38 BST 2014 - Plugman: store @$ or else it gets overwritten - Commit: 65ba2a4f3 6.83 Mon May 27 10:40:09 BST 2013 - NickServID: React on IRC Message 433 - Commit: ec7cd33736 - BotCommand: Support for overriding the Command Handler - BotCommand: Added Support for a Help Modification Callback - BotCommand: Adapted the Help Callback Options so it gets the Command and Arguments - BotCommand: Added Support for Command Aliases - BotCommand: Allowed No Arguments/Only Variable Arguments - Implemented SSL Client Cert Support 6.82 Sat Mar 9 22:15:02 GMT 2013 - Add the Prefix to the "Syntax:" line of the command help 6.81 Fri Nov 23 15:53:11 GMT 2012 - Resolve hash randomisation issues with v5.17.6 6.80 Thu Sep 20 09:52:59 BST 2012 - Add missing prereq 6.79 Wed Sep 19 14:24:03 BST 2012 - Argument naming and argument count validation in Plugin::BotCommand - [rt.cpan.org #79745] nick_long_form dies due to a race condition 6.78 Wed Dec 7 20:29:45 GMT 2011 - Prevent an IPv6 test failure 6.77 Fri Dec 2 03:55:14 GMT 2011 - Prevent a test failure in 06_online.t if the host is K-lined 6.76 Tue Nov 29 03:24:55 GMT 2011 - DCC.pm: Fix DCC RESUME, it was broken - NickReclaim.pm: Make it more robust and prevent an error from being raised when we quit from IRC. 6.75 Sun Nov 13 14:24:50 UTC 2011 - Win32 fixes to the DCC plugin and netsplit test - You couldn't specify a localaddr without a localport. Fixed. 6.74 Sun Oct 9 20:16:13 GMT 2011 - Disable authentication in t/01_base/04_pocosi.t. Fixes test failure. 6.73 Sat Oct 8 04:40:18 GMT 2011 - Add missing dependencies to t/inc needed by poco-server-irc 6.72 Fri Oct 7 15:41:53 UTC 2011 - Skip IPv6 tests on systems which don't have inet_pton() - Fix regression in t/03_subclasses/01_state.t - Update the poco-server-irc in t/inc to version 1.53 6.71 Sun Sep 18 16:07:33 GMT 2011 - Make the component easier to use with dynamic IP interfaces - Fix race condition in 06_state_nick_sync.t - Silence warning due to incorrect use of length() instead of defined() - State.pm: Add a parameter to irc_topic containing the old topic 6.70 Tue Aug 2 03:38:52 GMT 2011 - State.pm: Support multiple modes in NAMES replies (NAMESX, multi-prefix) - State.pm: Support nick!user@host in NAMES replies (UHNAMES) - State.pm: Added channel_url() - Fixed a race condition in 06_state_nick_sync.t 6.69 Fri Jul 29 01:52:38 GMT 2011 - Whois.pm: Collect info from numerics 307 and 310 - Whois.pm: Removed the 'account' key and have the 'identified' key do its thing instead, so that there is one generic way to check if a user is identified, regardless of the network. 6.68 Sun May 22 17:01:21 GMT 2011 - REALLY fix it to work with the latest IRC::Utils 6.67 Sun May 22 16:43:27 GMT 2011 - Add missing documentation for irc_plugin_(add|del|error) events - IRC.pm: Improved the layout of the documentation - Common.pm: Fix to work with latest IRC::Utils 6.66 Thu May 19 22:32:07 GMT 2011 - BotCommand.pm: Allow commands to be \S+, not just \w+ 6.65 Thu May 19 01:54:21 GMT 2011 - BotCommand.pm: Quote the 'Prefix' before using it in a regex, and add 'Bare_private' to allow commands in private without a prefix 6.64 Sun May 15 09:59:12 GMT 2011 - Fix incorrect amount of tests skipped in 04_ipv6.t when IPv6 is not supported 6.63 Sun May 15 05:06:57 GMT 2011 - Remove vestigial 'unregister' event handler, poco-syndicator handles that now. The latest poco-syndicator release croaks if we try to override its handler, so this was causing failures. 6.62 Tue May 3 10:58:45 GMT 2011 - Make use of IPv6 functions from Socket (instead of Socket6) if they are available, and skip the IPv6 test if we don't have an implementation of getaddrinfo(). Thanks to Apocalypse for this. - Add a parameter to irc_snotice which contains the target of the message (usually '*' or 'AUTH' or something). - Qnet/State.pm: Forgot to import parse_user() from IRC::Utils. - IRC.pm: Document the Bitmode parameter and make it 8 (+i) by default. - IRC.pm: Remove a sizable chunk of the code and inherit from POE::Component::Syndicator instead. Got rid of an old backwards compatability workaround in the process: sessions will no longer receive irc_connected/irc_disconnected/irc_shutdown events if they didn't register for them. - Console.pm: Avoid custom stringifications when dumping objects - State.pm: nick_info() was failing when a nick was known but unsynced - Console.pm: Decode all arguments before printing them 6.61 Tue Apr 19 17:02:54 GMT 2011 - The changes to the filter test were causing failures on <5.12 due to C. Fixed it. - Make it so that irc_shutdown is always the last event to be sent - Depend on POE 1.310 to fix failing socket error test on Windows - Improve event queue ordering to make it more predictable. Add new methods, send_event_next() and send_event_now(), to bypass the event queue in different ways. - Replace the functions in Common.pm with wrappers around equivalents from IRC::Utils. - IRC.pm: Add server() and port() accessors. 6.60 Fri Apr 15 06:12:28 GMT 2011 - Fix failure (RT #67465) related to the recent irc_snotice change. Added a test for it as well. 6.59 Mon Apr 4 20:22:38 GMT 2011 - FollowTail, Logger & DCC: Use rel2abs instead of abs_path to preserve symlinks while still being unaffected by chdir() 6.58 Mon Apr 4 17:48:59 GMT 2011 - Fix FollowTail test to work in case /tmp is a symlink 6.57 Sat Apr 2 03:34:04 GMT 2011 - FollowTail, Logger & DCC plugins: Expand '~' in filename arguments, and resolve them to absolute paths, in case the process will chdir(). 6.56 Fri Apr 1 20:05:14 GMT 2011 - irc_snotice has been used for server NOTICEs which do not have a sender prefix. NOTICEs which have a server name as the sender prefix are now irc_snotice too, leaving irc_notice only for notices with a proper nick!user@host sender. 6.55 Fri Apr 1 18:37:49 GMT 2011 - State.pm: Store the real nicks of channel members after receiving a NAMES reply. Fixes the issue of undefined nicks being returned by channel_list() before the channel has been synced. - State.pm: Check all arguments for definedness in public methods for easier debugging 6.54 Thu Mar 10 18:20:47 GMT 2011 - Fixed all the trailing space 'errors' - Resolve an issue with irc_nick_sync in poco-irc-state, added test 6.52 Fri Nov 5 18:27:16 CET 2010 - Fixed typo in shutdown code and added a test to confirm 6.51 Fri Nov 5 12:28:14 CET 2010 - Make the t/02_behavior/06_online.t test a TODO, since we can't work around problems such as the user being K-lined from FreeNode - Save the sender id on shutdown, not the sender's reference, avoids a crash when a sender disappears before we complete the shutdown 6.50 Wed Nov 3 02:05:56 GMT 2010 - Fix race condition causing a duplicated test in t/04_plugins/12_autojoin/03_banned.t - Console.pm: Dump hashes and arrays recursively - Enable all debugging messages if $ENV{POCOIRC_DEBUG} is true - Make the 'shutdown' event do more work for us, such as forcibly disconnecting after a timeout if the server doesn't disconnect us following a QUIT command - Add an irc_raw_out event, corollary to irc_raw - AutoJoin.pm: Don't require the component to be ::State 6.49 Sat Oct 16 19:05:25 GMT 2010 - Add draft-mitchell-irc-capabilities-02.html to docs/ - Fix incorrect number of skipped tests in 06_online.t in some cases - Allow IRC server passwords which evaluate to false (e.g. '0') - Prevent possible race conditions in a few tests 6.48 Sun Oct 3 19:49:20 GMT 2010 - State.pm: Don't send an undefined value with irc_chan_mode when the mode has no argument - Console.pm: Improve the readability of the output, and show undef - Deliver irc_plugin_error immediately, bypassing the event queue 6.47 Sun Oct 3 15:28:50 GMT 2010 - Join arguments to the 'quote' command with spaces. This allows us to send commands with multiple arguments through the Console plugin. - Add support for CAP command/replies. We use it to enable the server's identify-msg feature when we connect. - State.pm: In disconnected/error/socketerr events when no info is available, make ARG1 an empty hash reference instead of undef. - Console.pm: Don't send events to client before they're authed - Console.pm: Pretty-print hash references 6.46 Wed Sep 29 04:57:42 UTC 2010 - Document the 'debug' parameter. - Use Object::Pluggable instead of POE::Component::Pluggable. This smooths out an inconsistency between plugins and normal sessions with regard to events where extra arguments have been added. 6.45 Sun Sep 26 03:41:48 GMT 2010 - Don't create a POE::Component::Client::DNS object if the user has supplied one. This fixes a regression introduced by yours truly a couple of years ago. 6.44 Sat Sep 25 23:34:11 GMT 2010 - Don't fail on IRC servers where a whole class of channel modes is unsupported (e.g. Bitlbee). 6.43 Sat Sep 25 21:30:36 GMT 2010 - State.pm: Don't forget to call IRC.pm's implementation of S_disconnected before our own. Due to this, the logged_in() method was reporting incorrect information after disconnecting. 6.42 Sat Sep 25 09:40:21 UTC 2010 - ISupport.pm: Don't send a premature irc_isupport event on networks which send us numerics higher than 005 before the actual 005 (e.g Rizon) - NickServID.pm: Send an 'irc_identified' event when we've identified with NickServ. In addition, be a little more permissive when determining if we have identified. Works with Rizon now. 6.41 Thu Sep 23 21:33:17 UTC 2010 - Don't use qw() as parentheses, it's deprecated in 5.13.4 - Drop CTCPs which don't have a closing delimiter 6.40 Thu Sep 9 06:55:27 UTC 2010 - AutoJoin.pm: Wait for a reply from NickServ before joining channels on connect 6.39 Sat Sep 4 02:16:28 UTC 2010 - AutoJoin.pm: Allow channel keys to be undefined - Make the 'nickserv' command do the right thing on ratbox ircds - Add a server_version() method 6.38 Fri Sep 3 18:33:50 UTC 2010 - Only process the first CTCP chunk we find in a message. This prevents someone from flooding our outgoing queue by having us e.g. reply to 20 VERSION requests at a time. - CTCP.pm: Reply to VERSION with "dev-git" when no version is available. 6.37 Tue Aug 17 22:53:22 GMT 2010 - Make all warnings fatal - Use real temp files in tests instead of littering the dist directory 6.36 Mon Jul 26 03:53:50 GMT 2010 - Added a logged_in() method to see if we're logged into IRC 6.35 Sun Jun 27 09:32:22 GMT 2010 - Disconnecting.pod: Mention when it is appropriate to use C<< $irc->yield('shutdown') >>. - Connector.pm: Clear the reconnect timer when the plugin is deleted so that we can actually shut down the IRC component. - Depend on POE::Component::Pluggable 1.26 for irc_plugin_error 6.34 Fri Jun 25 18:16:40 GMT 2010 - CTCP.pm: Do "use POE::Component::IRC;" to avoid weird failures when this plugin is compiled by code which hasn't done the same. 6.33 Mon Jun 21 20:27:42 GMT 2010 - BotCommand.pm: Allow user to choose how help messages are delivered - BotCommand.pm: Require the command prefix in private messages - BotCommand.pm: Make the help messages more context-sensitive - BotCommand.pm: Add support for custom auth checks - BotCommand.pm: If Eat == 1, we eat everything that looks like a command - Cookbook: Add Gtk2 example by Damian Kaczmarek - Logger.pm: Support a hook for custom log storage - IRC.pm: Remove redundant version() method - Convert distribution over to Dist::Zilla 6.32 Tue May 11 13:43:50 GMT 2010 - IRC.pm: Filter out \r in arguments to non-PRIVMSG commands too - IRC.pm: Uppercase REHASH/DIE/RESTART commands before sending them - IRC.pm: Simplify privmsg handler and remove undocumented behavior of concatenating multiple messages. 6.30 Mon May 10 14:34:54 GMT 2010 - Proxy.pm: Fix documentation error ('bindaddr' -> 'bindaddress') - IRC.pm: Split long messages on \r as well as \n. Plugs a security hole. 6.28 Sun Mar 14 10:50:43 GMT 2010 - Use utf8 encoding in all Pod - Cookbook: Replace the MegaHAL recipe with a Hailo one - Stop using Module::Install::AuthorTests since M::I 0.94 handles it automatically for us 6.26 Sun Mar 14 07:32:23 GMT 2010 - Depend on POE 1.287 for FollowTail bugfixes - Updated documentation to mention advice about avoiding the double encoding of non-ASCII channel names - Logger.pm: Avoid double-encoding non-ASCII channel names in logs 6.24 Fri Feb 12 02:45:21 GMT 2010 - NickServID.pm: Identification wasn't working after the change a couple of releases ago. Thanks to John O'Brien in RT #54530. (Hinrik) 6.22 Wed Jan 20 01:50:23 GMT 2010 - Logger.pm: The 'Restricted' switch had the opposite of the documented effect. Fixed that and also changed the default to true, so nobody who used the default will see a change. (Hinrik) 6.20 Fri Jan 15 18:38:44 GMT 2010 - NickServID.pm: Identify correctly when switching nicks on ratbox IRC servers (Hinrik) - Common.pm: Encode::Guess::guess_encoding() doesn't work well with 'UTF-8', revert back to 'utf8'. Added tests for it. (Hinrik) - CTCP.pm: It was sending "ARRAY(0x#######)" in reply to CTCP PING. Fixed it and added test for that and CTCP TIME. (Hinrik). - Depend on POE 1.284 so we won't get FAIL test reports from CPAN testers because of the FollowTail plugin. (Hinrik) 6.18 Fri Dec 11 19:23:24 GMT 2009 - NickReclaim.pm: Reclaim nick immediately when possible (Hinrik) - Depend on POE::Filter::IRCD 2.42. Fixes parsing of 005 numeric replies from some servers (Hinrik) 6.16 Sun Oct 11 08:57:18 GMT 2009 - BotTraffic.pm: Emit 'irc_bot_notice' events for bot notices (Hinrik) - Logger.pm: Log NOTICEs if requested (Hinrik) - Proxy.pm: Fix a regression introduced in 6.05_01. This was causing it to be completely broken. Added a test so it won't happen again unnoticed (Hinrik) 6.14 Thu Sep 24 15:07:05 GMT 2009 - More "return" -> "return PCI_EAT_NONE" fixes. This eliminates some harmless (but annoying) warnings. (Hinrik) - State.pm: Fix AwayPoll, which wasn't working at all. Also added a test for it and made the documentation clearer. Thanks to David E. Wheeler for spotting that one. (Hinrik) - IRC.pm: Document which spawn() options can not be passed to the 'connect' event. (Hinrik) - IRC.pm: Split PRIVMSGs with newlines into multiple messages. For other commands, don't pass user-supplied newlines through to the IRC server as it allows the user to submit raw IRC commands. (Hinrik) 6.12 Thu Sep 10 09:25:02 BST 2009 - Fix localaddr() issue reported in RT #48791 by Michael Andreen - Depend on latest (1.24) POE::Component::Pluggable (Hinrik) - BotCommand.pm: Strip colors/formatting before processing (Hinrik) - Plugin::AutoJoin S_join should return PCI_EAT_NONE if $joiner ne $irc->nick_name() (perigrin) 6.10 Fri Aug 14 21:19:07 BST 2009 - Implemented netsplit detection and handling of state on netjoin (bingos) - Refactored the netsplit code for robustness and sanity (bingos) - Added testcase for netsplit handling (bingos) - AutoJoin.pm: Fixed problem with rejoining password-protected channels that were not passed to the plugin constructor (Hinrik) - Removed extended debug output from some tests, they've been behaving for a while (Hinrik) - State and subclasses will use NAMES replies to synchronise channel state as well now. Should help RT #46825 (bingos). - Refactored the netsplit test slightly to try and eliminate race conditions (bingos) - Added netsplit detection code to Qnet::State subclass. (bingos) - Netsplit restoration now triggers irc_nick_sync event (bingos) - Added some diagnostics to the netsplit test. (bingos) - Markup test in netsplit as todo due to race condition (bingos) - Mark one of the netsplit tests TODO (bingos) - Time for a stable release 6.08 Fri May 29 11:46:45 GMT 2009 - CTCP.pm: Return an RFC822 date in response to CTCP TIME (Hinrik) - BotCommand.pm: Fix RT #46065, help message wasn't being printed (Hinrik) - Connector.pm: Make the traffic-noticing code more accurate (Hinrik) - PlugMan.pm: Allow custom auth checks for the IRC interface (Hinrik) - PlugMan.pm: Silence some warnings (bingos) 6.06 Thu Apr 30 12:05:04 GMT 2009 - NickServID.pm: Update a paragraph in the Pod (Hinrik) - State.pm: Don't delete all state in S_(error|socketerr|disconnected) handlers, removes some warnings (Hinrik) - AutoJoin.pm: Fixed some bugs, added more tests (Hinrik) - PlugMan.pm: Don't rely on State.pm for authentication. Eliminates race condition when receiving channel commands before the channel has been synced (Hinrik) - In jailed environments we can't assume that 127.0.0.1 will be that. reported by Jase Thew (Bazerka). - Logger.pm: Replace slashes with underscores before logging to disk, spotted by Sebastian Mair. 6.05_01 Sat Apr 11 09:18:28 GMT 2009 - Compat.pm: Don't emit an extra event or print a misleading debug message for CTCP ACTIONs on FreeNode (Hinrik) - AutoJoin.pm: Only join channels after we have asked the server if it supports FreeNode's CAPAB IDENTIFY-MSG (Hinrik) - BotCommand.pm: Accept commands in private too (Hinrik) - CTCP.pm: Handle CLIENTINFO as well (Hinrik) - Common.pm: Added irc_to_utf8 to decode IRC messages (Hinrik) - Proxy.pm: General cleanup. Also fix a bug introduced in 5.66 that caused it to keep too many welcome messages (Hinrik) - State.pm: General cleanup. Fixed a bug with the order of irc_nick_sync's arguments being reversed (Hinrik) 6.04 Sat Mar 7 23:31:11 GMT 2009 - Logger.pm: Only use portable strftime parameters. Fixes log timestamps on Solaris and Windows (Hinrik) - CTCP.pm: Use portable strftime parameters when responding to CTCP TIME requests (Hinrik) - State.pm: Document the extra parameters to irc_disconnected, irc_error, and irc_socketerr. (Hinrik) - Fixed race condition in some tests (Hinrik) 6.02 Fri Mar 6 10:54:22 GMT 2009 - Fix RT #43856, variable name typo in PlugMan.pm reported by barnaclebob - Add new test for PlugMan plugin (Hinrik) - Amend a few tests that were failing (Hinrik) - State.pm: Avoid a warning when setting a mode on a channel on which all previous modes have been unset (Hinrik) - Add optional Perl::Critic test for the test scripts (Hinrik) 6.00 Wed Mar 4 23:12:57 GMT 2009 - Logger.pm: Fix bug with logging some CTCP ACTIONs (Hinrik) - Logger.pm: Also log own messages in DCC chats. Add test for it (Hinrik) - Added more tests for general IRC activity, and for State.pm (Hinrik) - Added tests for BotCommand and Logger plugin (Hinrik) - Turned off flood control in all the tests, and removed or adjusted many of the delays used. This shaves about 70% off the time needed for a full test suite run (Hinrik) 5.98 Mon Mar 2 22:51:27 GMT 2009 - Parse some IRC protocol messages more strictly. Always split on ASCII space rather than \s, since tabs are not considered whitespace by the IRC protocol. (Hinrik) - DCC.pm: Most events now tell you what the peer's IP address is (Hinrik) - DCC.pm: Document the timeout parameter to the dcc command, and fixed some errors in the docs. (Hinrik) - Compat.pm/DCC.pm: Actually provide the whole nick!user@host (not just the nick) with every dcc_request, like the synopsis suggests (Hinrik) - DCC.pm: Fix crash when closing a DCC connection with pending outgoing data, reported by meneldor (Hinrik) - Added test case for the above (Hinrik) - DCC.pm: Don't crash if dcc_close is called with an invalid id, also reported by meneldor (Hinrik) - Logger.pm: Add DCC chat logging (Hinrik) - IRC.pm: Document the 'account' key returned by irc_whois (Hinrik) - IRC.pm: Allow plugins to respond to custom commands without them having to be defined explicitly in IRC.pm. This allows the removal of the last piece of DCC-specific code (Hinrik) - AutoJoin.pm: Add an option for retrying joins when banned (Hinrik) - NickServID.pm: Support ratbox-based ircds (Hinrik) - Synchronised all the version numbering (bingos) 5.96 Wed Jan 28 11:29:28 GMT 2009 - Added delays to the two failing tests reported by CPAN Testers, believe we are seeing race conditions. (bingos) 5.94 Tue Jan 27 21:38:51 GMT 2009 - Fixed dependency on Date::Format in inc. poco-server-irc (bingos) 5.92 Tue Jan 27 13:18:12 GMT 2009 - PlugMan.pm: Only require ::State when 'botowner' is set (Hinrik) - ISupport.pm: Fix parsing of MODES and SILENCE parameters (Hinrik) - AutoJoin.pm: Added 'Rejoin_delay' option (Hinrik) - Connector.pm: Allow adjusting the time to wait before reconnecting, to ease testing. (Hinrik) - Compat.pm: Fix parsing of CTCPs when no prefix is present (i.e. client CTCPs) (Hinrik) - Updated included POE::Component::Server::IRC to 1.36 (Hinrik) - Fixed up some tests to work with it (Hinrik) - Removed ziplink test since PoCo-Server-IRC only supports server ziplinks, not client ones (Hinrik) - Added tests for the following plugins: AutoJoin, BotAddressed, CycleEmpty, CTCP, Connector, ISupport, NickReclaim, Whois (Hinrik) 5.90 Thu Jan 22 10:52:53 GMT 2009 - Seen.pod: Recipe for a bot implementing the 'seen' command (Hinrik) - Reload.pod: How to reload your bot with out reconnecting (Hinrik) - Memory leak with stashing $self in $self->{alias}, change to stash a stringified version of $self instead. (bingos) 5.88 Thu Aug 28 15:49:48 BST 2008 - MegaHAL.pod: Bare-bones recipe for a MegaHAL bot (Hinrik) - BotCommand.pm: Send responses back via NOTICE, not PRIVMSG (Hinrik) - Filter/CTCP.pm: Removed, as it is deprecated and unmaintained (Hinrik) - IRC.pm: Really propagate the plugin_debug flag (Hinrik) - Filter/IRC/Compat.pm - change to _get_ctcp() as per RT #38773 5.86 Tue Jul 22 09:53:26 BST 2008 - Proxy.pm: Remove 'options => {trace => 1}' from constructor (Hinrik) - Compat.pm: Don't handle CAPAB IDENTIFY-MSG with non-ACTION CTCPs (Hinrik) 5.84 Thu Jun 26 19:55:41 BST 2008 - BotAddressed.pm: Made it a little smarter (Hinrik) - Common.pm: Make strip_color() strip bg color-only changes (Hinrik) - IRC.pm: Propagate plugin_debug flag to Pluggable (Hinrik) - IRC.pm: Added support for FreeNode's CAPAB IDENTIFY-MSG (Hinrik) - Makefile.PL: Depend on new Pluggable for better debug info (Hinrik) - t/02_behavior/12_delays.t: Shouldn't fail if there's an IRC server running on localhost (Hinrik) 5.82 Sat Jun 14 09:02:11 BST 2008 - Depend on new PoCo-Pluggable to fix a regression (Hinrik) 5.80 Thu Jun 13 15:30:08 GMT 2008 - CycleEmpty.pm: Renamed cycling() to is_cycling() (Hinrik) - IRC.pm: Documented the squit command (Hinrik) - Only test ziplinks given a proper version of *Zlib::Stream (Hinrik) - DCC.pm: Implemented DCC RESUME support (Hinrik) - Cleaned up and reorganized the test suite (Hinrik) - IRC.pm: Added SERVLIST and SQUERY commands. Should include everything from RFC2812 now. (Hinrik) - Fixed a bug in Proxy plugin (bingos) 5.78 Fri May 30 08:03:30 BST 2008 - Logger.pm: Fix the PART thing properly (Hinrik) - README: A few updates (Hinrik) - Proxy.pm: Fixed a small bug (Hinrik) - Common.pm: Fixed the docs for matches_mask_array() and allow it to be exported (Hinrik) - IRC.pm et al: Improved some warning messages (Hinrik) - IRC.pm: Moved DCC support to a plugin (Hinrik) - IRC.pm: Improved the docs some. Better index and more links. (Hinrik) - The plugin system now uses POE::Component::Pluggable (Hinrik) 5.76 Thu Apr 24 15:05:05 GMT 2008 - Logger.pm: Fixed serious typo in function name. Grr. (Hinrik) - Logger.pm: Handle PARTs correctly when there's no colon (Hinrik) - State.pm: Only WHO users once even if they join many chans (Hinrik) - State.pm: Added channel_creation_time() method (Hinrik) - State.pm: Made channel_modes() return mode arguments as well (Hinrik) - State.pm: Add is_channel_synced() (Hinrik) - PlugMan.pm - bug in new() spotted by plu (bingos) 5.74 Thu Apr 03 15:14:04 GMT 2008 - Logger.pm: Do charset conversion on everything, not just messages. This should handle non-ASCII channel names and nicknames on servers that support such things (Hinrik) - Logger.pm: Allow custom formats to provide their own timestamp in the topic_set_by handler (Hinrik) 5.72 Fri Mar 21 10:33:59 GMT 2008 - Compat.pm: Fixed a bug that caused a warning (Hinrik) - Patch applied from Somni [RT #33850] (bingos) - Fixes to two of the tests that were causing intermitent fails (bingos) - Logger.pm: Make logging work again :) (Hinrik) - Logger.pm: Fix topic_change log string (Hinrik) - State.pm: Document new AwayPoll behavior correctly (Hinrik) - Moved author tests to xt/ Module::Install::AuthorTests is now required by maintainers. (bingos) 5.70 Mon Mar 03 10:51:01 GMT 2008 - BotAddressed.pm: Fixed a small bug (Hinrik) - BotCommand.pm: A new plugin for handling bot commands (Hinrik) - IRC.pm: Shorten protocol lines that are too long, make the maximum length configurable. (Hinrik) - Amended IRC::Compat to do CTCP parsing. Amended dependent modules. (bingos) - Logger.pm: Use File::Spec for cross-platform file/dir creation. (Hinrik) - Make CTCP plugin respond to SOURCE requests (Hinrik) - Added a Cookbook (Hinrik) - State.pm: Save user hop count from WHO replies (Hinrik) - Connector.pm: Added support for multiple servers (Hinrik) - IRC.pm: Improved dcc_resume documentation, moved some others things around in the docs (Hinrik) - Added Hinrik to the maintainers list in IRC.pm (bingos) 5.68 Wed Feb 20 19:49:58 GMT 2008 - IRC.pm: Improved the docs a little, fixed an error in the SYNOPSIS and moved half of it to an example file. Should be less daunting now :) (Hinrik) - State.pm: Lengthen away status polling time to 5 minutes and make the feature optional. (Hinrik) - Common.pm: Improved mIRC color handling code/documentation (Hinrik) 5.66 Mon Feb 18 21:58:48 GMT 2008 - Removed Filter::IRC in favor of Filter::IRC::Compat (Hinrik) - Filter/CTCP.pm: Support filenames with spaces in DCCs (Hinrik) - IRC.pm: Always doube-quote sent DCC files for safety (Hinrik) - Compat.pm: Propagate debug flag to internal CTCP filter (Hinrik) - Updated t/perlcriticrc to exlude a few more policies (Hinrik) - Cleaned up all code and documentation. The changes include: everything needed to satisfy Perl::Critic, use carp/croak instead of warn/die where appropriate, use 4-column indents, use consistent coding style everywhere, some refactoring here and there... (Hinrik) - put Filter::IRC back. It is now a Stackable/IRCD/Compat mash-up (bingos) - full regression testing in 1_filter_compat.t yippee. (bingos) 5.64 Sat Feb 16 07:55:34 GMT 2008 - Logger.pm: Fix regression regarding utf8 detection (Hinrik) - Logger.pm: Don't log channel modes which have different meanings depending on the IRC network we're on. (Hinrik) - NickServID: Tweak it a little (Hinrik) - Add optional Test::Perl::Critic test to detect risky code. Currently 466 violations in about 16k lines of code, whee! (Hinrik) - ISupport.pm: Fix bug in CHANLIMIT handling (Hinrik) - Logger.pm: Missing S_001 return value (Hinrik) - Compat.pm: Fix missing raw_line (Hinrik) - Filter/CTCP.pm: Stop using POE::Filter::IRC (Hinrik) 5.62 Thu Feb 7 16:31:03 GMT 2008 - IRC.pm: Document the nickserv command (Hinrik) - Common.pm: Show some example usage of has_color() (Hinrik) - CycleEmpty.pm: New plugin to cycle empty channels in order to gain channel operator status (Hinrik) - Common.pm: Add more color/formatting codes (Hinrik) - Added plugin test for CycleEmpty (BinGOs) 5.60 Wed Feb 6 13:38:50 GMT 2008 - State.pm: Improved the away tracking code (Hinrik) - Logger.pm: Added missing argument preventing quit messages from being logged (Hinrik) - NickReclaim: Fixed regression introduced in 5.58 (Hinrik) - BotTraffic.pm: irc_bot_ctcp_action => irc_bot_action, to be consistent with BotAddressed.pm (Hinrik) - AutoJoin.pm: Delay autojoin if NickServID is loaded, so the user will be cloaked (if applicable) before joining channels (Hinrik) - Common.pm: Add constants and methods for dealing with colors and formatting (Hinrik) - IRC.pm: Add NICKSERV command, mention the new color stuff (Hinrik) - NickServID: Made it behave more sensibly considering upcoming FreeNode policy changes. Also, use a raw NICKSERV command (Hinrik) - Logger.pm: Rename SortByDate to Sort_by_date and add Strip_color, Strip_formatting (Hinrik) 5.58 Mon Feb 4 07:58:14 GMT 2008 - State.pm: Workaround for IRC servers (e.g. hybrid, hyperion) which send user WHO replies starting with the name of a random channel that the user is on (which the component might not be on) instead of '*' (Hinrik) - State.pm: Track the away status of channel users and send an event if the status changes (Hinrik) - Projects.pm: Some additions and cleanup (Hinrik) - Logger.pm: Add 'Restricted' argument for restricting read permissions of created files/dirs (Hinrik) - Logger.pm: Add 'Format' argument for specifying a custom log format (Hinrik) - Logger.pm: Close log files after writing to them (Hinrik) - Logger.pm: Omit date from timestamp if sorting log files by date (Hinrik) - Logger.pm: Always use present tense (Hinrik) - NickReclaim.pm: Small fix for an edge case (Hinrik) - BotAddressed.pm: Check for '$nick~ $text' as well (Hinrik) - NickServID.pm: Make it work if it's added before connecting (Hinrik) 5.56 Thu Jan 31 12:30:25 GMT 2008 - AutoJoin.pm: Silence some warnings (Hinrik) - Logger.pm: Add SortByDate argument to rotate logs (Hinrik) - Logger.pm: output something in English for every channel mode change (Hinrik) - Logger.pm: made the ACTION syntax distinct from the MODE syntax to allow for sane parsing of log files (Hinrik) - Fix bug causing NickReclaim plugin to only try to reclaim once (Hinrik) - Fix NICK/QUIT logging in Logger plugin (Hinrik) - Minor improvement and documentation update to BotAddressed plugin (Hinrik) 5.54 Sun Jan 27 09:21:27 GMT 2008 - Hinrik added numerous groovey plugins. Hinrik++ 5.52 Mon Jan 14 07:46:01 GMT 2008 - RT #32279: Filter/CTCP.pm doesn't provide raw_line by Hinrik 5.50 Sun Jan 13 10:19:05 GMT 2008 - RT #32271 reported by Hinrik - RT #32265 is_away() support by Hinrik 5.48 Thu Jan 10 20:13:10 GMT 2008 - Added plugin FollowTail, a tail following plugin 5.46 Thu Jan 3 15:12:21 GMT 2008 - 'irc_public' events should now be generated according to ISupport information 5.44 Tue Jan 1 13:58:15 GMT 2008 - Enhancement to part command to handle part messages. RT #32029 reported by Hinrik 5.42 Mon Dec 31 12:29:50 GMT 2007 - Amendments to NickReclaim plugin by Zoffix Znet 5.40 Wed Dec 26 10:55:18 GMT 2007 - Applied a patch from Hinrik to fix umode issues with State.pm 5.38 Thu Dec 6 17:24:23 GMT 2007 - CPAN Testers reports for dev releases look favourable, bumped for proper release. 5.37_02 Thu Dec 6 08:35:47 GMT 2007 - Added is_user_mode_set() method and 'irc_user_mode' event 5.37_01 Wed Dec 5 21:11:46 GMT 2007 - Added umode support to IRC::State 5.36 Thu Nov 1 13:51:02 GMT 2007 - Updated Module::Install to 0.68 5.34 Wed Jul 25 10:51:45 BST 2007 - Fixed abstract_from in Makefile.PL. 5.33_01 Tue Jul 10 17:53:01 BST 2007 - Moved documentation for connect() to spawn(); - Added CTCP PING to Plugin::CTCP; 5.32 Tue Jun 12 12:20:21 BST 2007 - Stable release after working around issues on Solaris. 5.31_05 Mon Jun 11 09:57:09 BST 2007 - Fixed an error in the SYNOPSIS example for Qnet::State; - More diagnostics to the ipv6 test to trigger on solaris; 5.31_04 Tue Jun 05 09:29:34 BST 2007 - More diagnostics to the ipv6 test to trigger on solaris; 5.31_03 Fri Jun 01 10:37:49 BST 2007 - More diagnostics to the ipv6 test to trigger on solaris; 5.31_02 Thu May 31 16:04:06 BST 2007 - More diagnostics to the ipv6 test to trigger on solaris; 5.31_01 Fri May 18 10:11:47 BST 2007 - Added a warning if UseSSL is specified but SSLify wasn't found, requested by H.Merijn Brand; - Added some diagnostics to the ipv6 test to trigger on solaris; 5.30 Tue May 08 19:25:06 BST 2007 - Applied a patch from dec for Plugin::Proxy.pm 5.29 Thu May 03 13:01:01 BST 2007 - 'irc_ctcp' events added by Aankhen`` 5.28 Tue May 01 14:50:08 BST 2007 - Applied a patch from dec to Plugin::Proxy. 5.27 Tue May 01 13:43:39 BST 2007 - Fixed a serious bug relating to PoCo-Client-DNS use, reported by dec 5.26 Sun Apr 29 15:19:56 BST 2007 - Fixed a bug relating to PoCo-Client-DNS use, reported by dec 5.25 Sun Apr 29 13:03:07 BST 2007 - Applied fix for problem with ipv6 support from bsmith - Fixed RT #26735 reported by dec 5.24 Mon Apr 16 13:43:36 BST 2007 - Changed the IPv6 support to only be enabled when 'useipv6' is explicitly used. 5.23 Thu Apr 12 16:07:56 BST 2007 - Added Test::Kwalitee test. - Added new IP functions to ::Common - IPv6 support for connecting to ipv6 ircds. - New IPv6 connect testcase. 5.22 Fri Feb 02 12:02:36 GMT 2007 - Found a bug in ::State that was causing problems during netsplits. 5.21 Thu Feb 01 12:21:45 GMT 2007 - More changes to Qnet::State to include AUTH in part/quit/kick events. Suggested by helios. 5.20 Wed Jan 31 17:25:31 GMT 2007 - Finally converted Makefile.PL to full Module::Install-ness. 5.19 Wed Jan 31 11:54:36 GMT 2007 - Change to ban_mask() method in Qnet::State, suggested by helios. 5.18 Fri Dec 29 10:55:05 GMT 2006 - Documentation fix to ::Plugin by Lyndon Miller. - Still a problem with TOPIC command. Fixed. 5.17 Tue Dec 12 22:52:48 GMT 2006 - Serious bug in TOPIC handling spotted. Fixed. 5.16 Wed Dec 06 11:54:08 GMT 2006 - Refactored the SOCKS code to use $wheel->event() to switch InputEvent. Thanks to dngor for pointing that out. 5.15 Tue Dec 05 19:26:34 GMT 2006 - Implemented SOCKS4 support. Requested by netmunky @ Efnet. Somni assisted with the design. Thanks! 5.14 Wed Nov 29 10:56:57 GMT 2006 - Found a serious problem with refcounts in the registration code. Fixed with merlyn's help. 5.13 Sun Nov 19 14:20:51 GMT 2006 - Fixed long standing bug in 'topic' command. 5.12 Thu Nov 16 14:04:51 GMT 2006 'Hairy COO!' - Documentation fix for ::Pipeline, spotted by Martijn van Beers. - Amended 6_common.t test-case to make sure it covered other edge case reported by 'Elvis Dead' via email. - Setting a delayed command with delay() generates a 'irc-delay_set' event. - Added ability to remove delayed commands. 5.11 Wed Oct 25 16:32:03 BST 2006 - Changed plugin processing so that any poco plugin handlers are now in an eval as well. Pesky edge-cases. - Refactored parse_mode_line() to handle dangerous edge cases. 5.10 Tue Oct 24 18:02:46 BST 2006 - ::State 'irc_kick' event has ARG4 which is the full nick!user@host of the kicked person. Suggested by helios. 5.09 Tue Oct 24 14:48:07 BST 2006 - Forgot a test with the Test::Plugin relocation. Damnit. - Reinstated ::Test::Plugin for the PlugMan tests. 5.08 Mon Oct 23 12:35:04 BST 2006 - Remove ::Test::Plugin and relocated code to the actual test. - Removed the optional debug in Pipeline. If there are errors you'll see them now. - New plugin tests, testing running POE sessions in plugins and dying in PCI_register(). - Deprecated 1_new.t test by removing it. 5.07 Tue Oct 17 11:37:28 BST 2006 - Enabled plugin_debug effect Pipeline. - Added send_event() method for injecting events in the event handling system. 5.06 Thu Oct 12 12:45:06 BST 2006 - Adjusted load() in PlugMan, suggested by Stefan Schwarzkopf. 5.05 Fri Oct 06 14:40:37 BST 2006 - ISupport documentation fix. - Amendments to plugin processing, plugin debugging should be less noisy now. 5.04 Mon Sep 25 13:30:46 BST 2006 - Removed Build.PL - Applied a patch from Ben Jackson which fixes the proxy support. Yay. 5.03 Sat Sep 16 14:17:01 BST 2006 - Switched Makefile.PL to using Make::Install. Added Build.PL - Fixed META.yml handling. - Fixed an unregister bug reported via CPAN::Forum. *sigh* 5.02 Fri Sep 08 16:32:12 BST 2006 - POE-0.37 has found a serious flaw in the shutdown() handler. Fixed. - ::Test::Harness was registering for HUP signal. Stopped that nonsense. 5.01 Thu Sep 07 17:53:00 BST 2006 - Fixed file permissions in the distribution. Again a CPANTS gripe. - Fiddled with State's insides. - Added find_auth_nicks method to Qnet::State, requested by helios. 5.00 Fri Sep 01 02:20:54 BST 2006 YAPC::EU Birmingham 2006 release - Test::Pod::Coverage test added, inspired by CPANTS hackathon, cheers, domm. - Added use strict to ::Constants. - PlugMan plugin will dump $@ when a plugin fails to 'load' now. - Documentation fixes to a lot of modules due to Pod::Coverage. 4.99 Tue Aug 29 17:47:04 BST 2006 - Added resync_chan and resync_nick to Qnet::State subclass, as suggested by helios. 4.98 Fri Aug 18 12:30:31 BST 2006 - Added support for connecting to ircds that support compressed links; only PCSI does this afaik, so limited use for most peeps. - Applied a patch from dec to fix a bug in ISupport plugin, RT #21058. 4.97 Mon Jul 24 12:46:26 BST 2006 - Fixed 'sconnect', it should send 'CONNECT' to the ircd now instead of 'SCONNECT'. - ::State assumed that ircd had returned ISupport info. Set reasonable defaults for ircd's that don't. - Changed 'sl' to 'quote' instead as far as the documented API. 4.96 Sun Jul 16 14:35:34 BST 2006 - Fixed a bug in Console plugin. - Minor code changes to Proxy plugin. - Component will automatically register a parent session if spawned from another session. Added testcase for this also. - Removed the deprecated IRC_EVTS registration bit from _start as the component uses plugin API stylee handlers now. - Tidied up PlugMan plugin code. - Updated documentation stipulating that the module is licensed the same as perl is. - Refactored Whois plugin. Added RPL_WHOISACTUALLY support. 4.95 Wed Jul 05 11:46:34 BST 2006 - Removed stray Dumper() in IRC.pm. - Fixed serious bug in ISupport plugin. 4.94 Sun Jul 02 10:01:45 BST 2006 - Amended the DNS code to implement round-robin type behaviour. - Added POCOIRC_REGISTER and POCOIRC_SHUTDOWN signals for multiple registration and shutdown, respectively. Added applicable tests to the testsuite. - Documentation fixes. Added DIE command. - Added multiple bot SYNOPSIS. 4.93 Tue Jun 13 19:25:45 BST 2006 - ::State, invex & excepts sync'ing when we +[qoah]. - ::State, documentation fixes. - Added 'irc_shutdown' event. - Bug in Qnet::State spotted by helios. Changed inheritance order and cpoied some code from Qnet to Qnet::State accordingly. 4.92 Sun Jun 11 18:09:13 BST 2006 - Added a check to _parseline for spurious blank events, reported by dec. - Added nick_channel_modes method to ::State to return the channel modes (ie. qaohv) of a given nick on a given channel - Lyndon Miller - Added note concerning the issues surrounding the SetAt and SetBy values to CAVEATS in the ::State pod - Lyndon Miller - Improvements to Plugin::PlugMan, it should actually work properly now >:) Thanks to mst and dngor. - ::State, nick_sync now has the channel name as ARG1. - Moved the INVEX and EXCEPTS sync'ing until we are +o'd, created irc_chan_sync_(invex|excepts). irc_chan_sync features the time in seconds taken to sync as ARG1 now. 4.91 Thu Jun 01 21:08:13 BST 2006 - Tweak to ::State to deal with ircds that don't report @+ status in WHO replies ( like unreal ). Thanks to Lyndon Miller for reporting that. - 'irc_dcc_failed' event was undocumented. Fixed. - Switched the poco-client-dns checks to 'use', so as to ensure that we only load >= 0.99. - Amendments to shutdown so that it sends a quit message to the ircd if we are connected. - Amended Connector plugin so the lag is collected independent of what the ircd sends us back. - Various changes to ::State in order to ensure full RFC compliant channel mode support, including support for channel access lists - Lyndon Miller - Added ::State methods to return channel access lists: channel_ban_list, channel_invex_list, channel_except_list - Lyndon Miller - Using 'use' for the dns checks was fubar. Switched back to 'require' and test the VERSION instead. - Changed the simpleclient.pl script to accept a filename as a second argument to /dump_state command. - Documentation tweaks to ::State by Lyndon Miller - Channel topic support added to ::State. Added the method channel_topic to return a hashref of topic data - Lyndon Miller - Changed 'Time' keys for channel lists and topic to 'SetAt' - Added irc_chan_mode event to ::State to allow everyone to enjoy the mode parsing State does internally - Lyndon Miller - Refactored ::Qnet::State subclass after all - Lyndon Miller changes to ::State. - Refactored ::State slightly to use ARG2 for numerics handlers instead of trying to parse ARG1 ourselves. FTW. 4.90 Mon May 22 13:23:09 BST 2006 - Missed the Filter::Stackable in plugins Console and Proxy. 4.89 Mon May 22 09:14:57 BST 2006 - A bug in POE-0.35's Filter::Stackable causing problems with ::Test::Harness. Enabled a runaround *sigh* 4.88 Sun May 21 17:57:38 BST 2006 - Code cleanup in ::Test::Harness. Workaround for systems without %z in strftime, like Solaris. - Added matches_mask() function to ::Common. Updated 6_common.t to add applicable tests. - Added parse_user() function to ::Common. Updated 6_common.t to add applicable tests. - new() deprecation warning specifies the module name. Saves confusion for people who are using Bot::* modules. - Added LUSERS command. - Major hackery to remove dependency on PoCo-Client-(DNS|Ident). 4.87 Sat May 06 17:03:34 BST 2006 - Testsuite 07 and 09 were still skipped on MSWin32. Fixed. - Altered BotAddressed at immute's suggestion. Check docs for details. - Altered Filter::Compat so it won't break with Stackable. - Added 'remove' command a Freenode extension. 4.86 Thu Apr 27 21:18:41 BST 2006 - POD fixes and perl dependency as pointed out by Alias. - Tweak so that the poco only shuts down PoCo-Client-DNS if we spawned it. - Spotted a problem with register() it was still stashing POE::Session refs. Bad BinGOs. - shutdown() will unregister all registered sessions now. - Code audits of State and Qnet::State. Lot's of cleanup. - Changed Common.pm u_irc/l_irc to support a casemapping argument, one may specify 'rfc1459', 'strict-rfc1459' or 'ascii'. Default is 'rfc1459'. - Changed State and Qnet::State to use casemapping for generating unique state keys. - Removed State::Lite. Deprecated. - Online test reports the server connected to. 4.85 Thu Apr 13 12:37:49 BST 2006 - Numerous bug fixes to State and Qnet/State which were causing terminations. Reported by dec. - Tweaks to a number of tests. - Various plugins have been debugged. - Added '/dump_state' command to simpleclient.pl. 4.84 Wed Apr 12 14:24:34 BST 2006 - Spotted a bug in Filter::CTCP, it wasn't setting raw_line. - Bug in dcc code meant DCC tests were failing on certain platforms. Fixed. - Changes to DCC tests. Rolled back MSWin32 skip checks. - Added one more DCC test for testing 'nataddr' option. 4.83 Tue Apr 11 20:45:04 BST 2006 - Changes to two of the DCC tests. DAMN YOU WINDOWS! 4.82 Tue Apr 11 19:32:45 BST 2006 - Sorted out Test::Harness, brought it up to PoCo-Server-IRC-0.3 standard. - Added a multiple client test to the testsuite. - Added socketerr test to the testsuite. - Added subclass test to the testsuite. - Added DCC test scripts to the testsuite. - Fixed a bug in DCC code for CHAT. - Added nick and nick_state tests. - Amended processing order in _send_event() so that the poco session can process events *before* the plugins do. - Plugin system will automagically check whether the poco object has any plugin handlers. These get processed first. - Removed the dependency on Date::Format, switched to POSIX::strftime. - Applied a patch from ketas for State.pm. - Fixes to Pipeline, spotted by dec @ MAGnet. - Added resolver() method for accessing the PoCo-Client-DNS object. - Refactored State.pm, Qnet.pm and Qnet/State.pm, handlers are all processed by plugin system now. Implemented better inheritance. - Expanded the SYNOPSIS sections of Qnet.pm, State.pm and Qnet/State.pm. - Added NickReclaim plugin and associated test. 4.81 Fri Mar 31 17:00:38 BST 2006 - Added PlugMan plugin manager and associated test. - Fixed the RFC docs in docs/. Spotted by integral. Thanks. - Added session_alias() method as suggested by Chris Thompson. - The component's HEAP is now the object. So is retrievable via $_[SENDER]->get_heap() in event handlers. Thanks to CT for the idea. Now why didn't I think of that sooner =[ - Various fixes to Test::Harness ircd. - Expanded the testsuite with 2 new tests. One uses Test::Harness, the other is an online test and tries to connect to freenode. - Fixed all the examples to use POE::Session->create(). - Added a warning to Makefile.PL about the online test. - Added delay() method for posting delayed commands. - Added a test to testsuite for ::State. - Added examples to Plugin docs. 4.80 Thu Mar 16 17:00:01 GMT 2006 - Code tidy up. - Fixed DCC bug. As reported by helios. - POD fix to ::State, missed two methods. - Changed default alias to "$self". Thanks dngor. - General POD rewrite. 4.79 Sun Jan 15 17:15:01 GMT 2006 - Serious bug in _send_event() spotted by ikaros @ freenode. The component wasn't dispatching events to itself since 4.78. 4.78 Tue Jan 10 22:01:09 GMT 2006 - Documentation bug. 'irc_topic' event wasn't documented. Reported by bluepunk @ efnet, through dngor :) - Finally got around to switch session registering from using POE::Session ( ew, nasty ) to session IDs instead. 4.77 Mon Dec 26 17:00:01 GMT 2005 - Forgot to add use ::Common to Qnet::State. Doh. 4.76 Fri Dec 23 15:20:20 GMT 2005 - Documentation bugs in the main IRC.pm SYNOPSIS. Bad BinGOs :( Spotted and reported by Mulander via email. - Added 'plugin_debug' option to dump after plugin evals if applicable. - Spotted a bug with the 'whois' handler. Looks like it has never worked ( properly ). Adjusted 'commasep' for the special case WHOIS mask,mask. - Minor fixes to Filter-IRC-Compat for argument handling. - Minor fixes to Pipeline and plugin_del(). 4.75 Sun Dec 04 17:45:20 GMT 2005 - Fixed a problem with DCC code. Thanks to ketas for the heads up. - Added disconnect() method with docs. - Code audit to make sure all event handlers return undef. - Updates to Connector plugin to fix timeout issues on connection. - Added tests for the included plugins: Connector,BotAddressed and BotTraffic. - Fixed dicebot.pl in examples/ problem with $SIG{INT}. - Updated docs to proxy support is SOCKS v4. - Added raw_events() method to enable/disable/display current irc_raw. - README updates. Notably to mention PoCo-SSLify for SSL links. - Stole japhy's ISupport plugin for .. erm .. new ISupport plugin >;] - Added CTCP.pm from gumbynet source. Added applicable test for it. - Added Console.pm from gumbynet source. Added applicable test for it. - Moved common functions to Common.pm. Amended relevant code to import functions from there. - Added Proxy.pm from gumbynet source. Hacked to make much more useful and robust. Added applicable test for it and added ircproxy.pl to examples/ folder. - Patch applied to BotTraffic plugin from immute. - Completely rehacked how the component handles parsing irc traffic to events. Now using Filter::IRCD with Filter::IRC::Compat to process all input. Input and output filters are stackable. - Patch applied to BotAddressed plugin from immute. 4.74 Wed Oct 26 09:15:21 BST 2005 - *sigh* another problem fixed with the new dns code. 4.73 Wed Oct 26 07:43:03 BST 2005 - Minor problem with PoCo-Client-DNS fixed. 4.72 Tue Oct 25 19:01:05 BST 2005 - Fix to Filter::IRC for INVITE. Apparently, asuka timestamps after the channel name. Doh. Thanks to Johannes Studt for spotting that. - Fixed the documentation in Projects.pm - Solved Ticket #15058, re: NoDNS and multiple PoCo-Client-DNS sessions. 4.71 Thu Oct 13 19:04:01 BST 2005 - Documentation bug in IRC.pm, spotted by cnelson. - Fixed ::State.pm for channel admin/owner support, spotted by Sebastien Wernerus. 4.70 Fri Sep 16 16:45:05 BST 2005 - Fixed a bug where 'irc_raw' events were being switched off after a connect() without parameters was called. 4.69 Mon Sep 05 12:30:01 BST 2005 - 3_connect.t was causing problems on Cygwin. Skipped this test on Cygwin for now. 4.68 Fri Sep 02 14:00:00 BST 2005 - Altered Connector plugin so it starts the auto_ping on 'irc_connected' rather than 'irc_001'. Thanks to British Telecom for enabling me to spot that one. >:] 4.67 - Documentation amendments to Plugin.pm. Well spotted, perigrin :D - Added POD test. - Filter-CTCP.pm fixed. All 'warn's only enabled when debug is set. Thanks to ketas for spotting that one. - Fixed a typo made doing the previous fix. >;) - Added Projects.pm, hopefully a list of PoCo-IRC using projects. - Added placeholder for State::Lite, a lightweight version of State. - Tidied up main PoCo-IRC POD. Added a much better SYNOPSIS. 4.66 Thu Jul 28 17:55:01 BST 2005 - Committed patches from Jeff 'japhy' Pinyan who has hacked prioritisation into the plugin system. Check Plugin.pm and Pipeline.pm for details. 4.65 Wed Jul 13 17:47:08 BST 2005 - Fixed the anamoly where plugins weren't deleted if shutdown() is called. This should fix plugins that based around POE::Session. 4.64 Tue Jul 05 16:25:01 BST 2005 - Fixed POD in Plugin::BotAddressed. - Added BotTraffic.pm plugin. 4.63 Thu Jun 16 21:55:49 BST 2005 - Fixed POD in BotAddressed and Connector plugins, thanks integral @ MagNET for spotting that one. - perigrin pointed out a problem with Test::Harness and dependent components. Updated distribution dependencies and amended Test::Harness accordingly. 4.62 Thu Jun 02 16:43:45 BST 2005 - Spotted another problem with ::Test::Harness, updated Makefile.PL with Date::Format dependency. 4.61 Thu Jun 02 10:38:05 BST 2005 - Found a bug in ::Test::Harness that made it fail tests where POE::Component::Client::DNS wasn't installed. Doh. 4.6 Wed Jun 01 15:28:03 BST 2005 - Applied another ketas patch. - Added BotAddressed plugin. - Added ::Test::Plugin. - Added ::Test::Harness, PoCo-Server-IRC in disguise :) - Added tests for the ::Test::* 4.5 Sun May 22 16:21:08 BST 2005 - Moved repository from cvs to svn \o/ - Applied patch from ketas. - Fixed docs for DCCPorts parameter to connect(). - Removed State.pm plugin as it was becoming difficult to keep in sync with State subclass. Eventually hope to replace State subclass with a proper plugin wrapper. - Relocated constants to Constants.pm, tidied up subclasses. - Added Connector.pm plugin. See docs for details. - PoCo-IRC will now send an 'irc_registered' event to registering sessions. ARG0 will the poco's object. 4.4 Thu Apr 28 15:16:03 BST 2005 - Added event handlers for PING and PONG IRC commands. - Added connected() method, so punters can query if the component is connected to an IRC server or not. - Applied a patch from Apocalypse re: DNS and SSL. - Fixed Filter::IRC so it now parses PONG properly. - ketas pointed out that in State.pm, the state for a channel wasn't getting deleted when the bot parted or got kicked. Fixed. 4.3 Wed Apr 20 09:25:21 BST 2005 - Added 'irc_raw' events and parameter to spawn/connect() to enable them. Thanks to webfox for the idea. 4.2 Thu Apr 14 12:00:00 BST 2005 - Minor changes to State.pm to delete the STATE info when we disconnect, error or socketerr. - Reorganised the distribution. 4.1 Mon Apr 11 11:24:44 BST 2005 - NATAddr bug spotted by apeiron @ MAGnet. Fixed. - webfox spotted a problem with whois plugin and POE Kernel assert_default. Hopefully fixed. 4.0 Tue Apr 05 10:39:42 BST 2005 - Fixed a minor bug in Filter-IRC.pm, where it wasn't decoloning the mode line before splitting it. Thanks to webfox for pointing it out. - Used eval's to make plugins system safe from rogue plugins. *tssk* *tssk* - Plugins system will now try to send events to a plugin method _default() if the call to S_* or U_* fails. - Applied a patch from webfox to enable SSL connections. \o/ - Ported SSL patch to all dependent sub-classes. - Teased and fixed a bug in IRC-State.pm. ban_mask() should work properly now. - paulv @ MAGnet pointed out that spawn() and connect() arguments are case-sensitive. Adapted his patch. Args can be in any case now. 3.9 Mon Mar 21 09:17:05 GMT 2005 - Applied patches from webfox @ MAGnet for UnrealIRCd support in IRC-State.pm and Plugin-State.pm. - Added plugin_list(). 3.8 Mon Mar 14 10:15:22 GMT 2005 - Applied ketas' DCC patch, eventually. - Applied a patch from Zsolt Szalai, which adds support for Freenode's 320 whois response. - Added Apocalypse's port of IRC-State.pm using the plugin API, Plugin-State.pm. - Added my plugin for 'irc_whois' and 'irc_whowas' functionality. - Fixed all the necessary modules to use Whois plugin. 3.7 Fri Mar 04 17:37:34 GMT 2005 - Applied massive patch from Apocalypse @ MAGnet that adds plugins. Read the docs in Plugins.pm for more info. - Corrected some grammar mistakes in Plugins.pm >:o) - Amended IRC-State.pm so that 'irc_nick' and 'irc_quit' have an additional parameter in ARG2 which is an arrayref of channels that are common with the component. 3.6 Tue Mar 01 17:47:05 GMT 2005 "Y Adeilad Daffydd-Sant" ( The Saint David Build(ing) ) - Applied ketas' patch to IRC-State. Adds channel_modes method and some code tidying. - Spotted that in some cases the component *needs* an alias. Made it use an internal alias unless one is specified. - Applied another ketas patch to IRC.pm, puts a friendly message when we can't allocate a DCC port. - Updated IRC-Qnet-State.pm to use a 'querytype' in the extended WHO command, to specify or WHO queries, due to spurious channels appearing in the state. Big thanks to MikeC @ Qnet for the pointers. 3.5 Wed Feb 23 13:28:05 GMT 2005 - IRC-State bug spotted and patched by ketas @ MAGnet - Same bug caught and squashed in IRC-Qnet-State by me. - Sorted out DCCPorts. It has to be an arrayref now. 3.4 Fri Feb 18 12:01:58 GMT 2005 - Deprecated new() in favour of new constructor spawn(). spawn() will except all the same parameters as connect(). Moved config stuff to _configure() to save duplication. - Changed all the object constructors about. Bit tedious but now it is alot easier to subclass. See _create(). - Added a hack for $self->session_id(). Made 'alias' optional if used with 'spawn'. - Added parameter NATPort so one can specify the NAT address that a bot appears to other IRC clients as for DCC transfers, etc. - Added DCCPorts parameter so that one can specify a range of ports to use for initiating DCC, instead of using 0. - Implemented and added subclass ::State which provides nickname and channel tracking. \o/ - Implemented and added subclass ::Qnet::State the ::State ported to the Qnet module. - Fixed the event dispatchers in _sock_up and _sock_down to use _send_event like everyone else. Danke to Apocalypse for spotting that. Amended _send_event so that 'irc_connected' and 'irc_disconnected' get sent to every session not just those that ask for it, as was the original behaviour. - Documentation updates for all the new stuff. - Added CVSLOG which contains all the glorious changes in developing this thingy. :) - Added send_queue() method, as I noticed that merlyn's logfile tailing code was accessing the heap and i moved all heap stuff to the object. *sigh* hacked it so that $heap holds a reference to $self->{send_queue} which should work. 3.3 Wed Feb 02 14:07:03 GMT 2005 - Updated IRC-Qnet to a). support new whois/whowas; b). support irc_330 which is the account on ircu. 3.2 Wed Feb 02 11:00:59 GMT 2005 - Implemented 'irc_whois' and 'irc_whowas' which gather all the salient data from the numeric replies and send one event containing a hashref. As suggested by numerous bods on #PoE @ MAGnet >;o) 3.1 Fri Jan 21 11:59:56 GMT 2005 - Converted _send_event sub to object method. - Added IRC-Qnet, with specific extensions for Quakenet. - Updated README 3.0 Fri Dec 31 09:00:01 GMT 2004 - Fixed Filter-IRC so that it groks WALLOPS properly. - Added docs/ and populated it with rfcs applicable to IRC. - Added a slightly more substantial test case, moved it to t/ - Converted use of HEAP to OBJECT. PoCo-IRC is *now* an object. - Added a fix for the infamous PART bug. Has to be explicitly enabled by specifying PartFix => 1 in the 'connect' handler. - Added a switch to 'connect' so that the use of PoCo::Client::DNS can be disabled if necessary. - Applied the outstanding patches: - PoCo::Client::DNS patch by Jim Westfall - DCC Resume patch by Bruno Boettcher - Flood doc patch by Rocco Caputo - Debug param patch by Paul Visscher - Proxy Support patch by Jeff Pinyan - Locops patch by Jon Nistor ========== Maintainership changed from Fimm to BinGOs ==================== 2.9 Sat Jul 19 13:32:45 PDT 2003 - Only one change this time: Adam Foxson's patch to add prioritized notices. 2.8 Sat Jun 7 16:13:25 PDT 2003 - Applied dngor's mega-patch, which fixes (among other things): a fix for a nasty lockup, improved error reporting, and better flood control. - Fixed some broken URLs and a couple mistakes in the documentation. 2.7 Sun Feb 2 15:05:28 PST 2003 - Fixed up the example scripts to play nicer with POE's new signal handling. Thanks to dngor for bringing this up. - Added a patch by lunartear to properly handle spaces in DCC filenames. - Fixed a bug reported by Robert Rendler regarding CTCP quoting accidentally duplicating backslashes. 2.6 Wed Dec 11 20:27:51 PST 2002 - Brian Kelly thoughtfully pointed out an URL in the documentation that was being mangled by pod2html. Should look better now. - Added a note about handling CTCP actions to the POD documentation, since that seems to be a source of confusion for a lot of people. - Added a 'list' event, which I seem to have overlooked entirely until now. Thanks to J.D. McCown for pointing it out. - Attempted to add Jim Westfall's asynchronous DNS patch, but I really need to learn a little more about IPv6 before I attempt to port somebody else's code to it. Hopefully in the next release. 2.5 Sun Oct 27 11:03:57 PST 2002 - Added an AIM <-> IRC proxy bot to the example scripts. Share and enjoy! - I just now noticed that POE::Component::IRC sessions never get garbage-collected. DOH. Now you can send them "shutdown" events to make them go away. Too bad it's probably too late to be breaking backwards compatibility on this... sigh. - Added a bug fix from Trym Skaar (those Norwegians get the coolest names!) which fixes a potential crash while closing DCC connections. - Added a mega-patch from the unstoppable Rocco Caputo which prioritizes messages sent to the IRC server by importance. This ensures that pings and login information will always keep flowing, even if your bot's inane chatter has been throttled. 2.4 Thu Oct 10 14:22:04 PDT 2002 - Added a patch from dngor to fix a crash caused by IRC servers sometimes inexplicably sending a blank line. - Added a patch from Jim Westfall which speeds up DCC file transfers by a couple orders of magnitude. Yay, Jim! 2.3 Fri Sep 6 07:59:50 PDT 2002 - Fixed a rare "uninitialized value" warning in oneoptarg(). - Added a patch from Trym Skaar which makes sure that DCC buffers are flushed before closing a connection. Thanks, Trym! 2.2 Fri May 24 13:00:44 PDT 2002 - dngor found an excellent page about IRC server numeric codes, which I added a link to in the documentation. - dngor also gave me two more patches: one to avoid some deprecation warnings introduced in the latest version of POE, and another which fixed a bug in one of his earlier patches. He's such a stud. 2.1 Mon Mar 4 17:06:03 PST 2002 - Added a long-buried patch from thefly to fix IRCnet channel name parsing. Sorry about the long turnaround on that one. - Applied Scott Beck's patch to Rocco's refcount patch. The whole "sessions not being GCed" brain-damage should be fixed now. 2.0 Fri Feb 22 15:23:23 PST 2002 - Rocco Caputo gave me two patches to apply; the first was a fix to his earlier output throttling patch, and the second was a snippet of code that will allow bot-writers to avoid having to set aliases on their control sessions to keep them alive. Cool! 1.9 Wed Dec 12 22:44:13 PST 2001 - David Dollar pointed out a bug with DCC using the wrong interface on multihomed hosts. Easy fix. 1.8 Mon Dec 10 16:04:06 PST 2001 - Applied dngor's studly patch to throttle line output. - Fixed a bug that would cause events to get thrown away if they came in while the connection to the IRC server was down. 1.7 Sat Jul 21 00:46:06 PDT 2001 - Fixed bugs in my initial implementations of the irc_invite event. Sigh. You ever have one of those days where you can't do anything right? Thanks again to the exceedingly patient Rasmus Hansen for pointing out that my updated version still didn't work right. - Fixed a bug in 'dcc_close' which prevented it from calling 'irc_dcc_done' handlers properly. 1.5 Thu Jul 5 15:24:31 PDT 2001 - Added an irc_invite event -- I knew I'd forgotten something! Thanks to Rasmus Hansen for the bug report. - Fixed a bug in topic() that would accidentally clear the topic when trying to query it. More thanks to Rasmus Hansen. 1.4 Mon Jul 2 17:10:59 PDT 2001 - One of the fixes in 1.3 broke newline handling horribly, such that it was sending two sets of line terminators on every line. I am a doofus. Patched by Rocco Caputo. 1.3 Sat Jun 30 17:29:30 PDT 2001 - The Indomitable Mark-Jason "Ominous" Dominus sent me so many patches and bug reports I'm almost at a loss to list them all. Among others, DCC SENDs no longer report the local pathname to the client on the other end, multiple concurrent DCC connections work, and some documentation errors have been fixed. - Many thanks to the infinitely studly Kees Cook, who, in addition to having a really cool name, sent me a big patch for lots of DCC bugs. DCC connections will now report errors and close their sockets properly! Woohoo! Also, 'irc_dcc_error' events give you more information about the connection that failed, and the 'dcc_accept' event now lets you rename incoming DCC files. - Fixed a silly bug; sl() was sending \n instead of \r\n as a line terminator. - Changed lots of Filter::CTCP die()s to warn()s, on the advice of Peter Barabas. Thanks, Peter! 1.2 Thu May 24 02:36:40 PDT 2001 - I have learned a valuable lesson about not including debugging prints in released code. Especially when the debugging code in question consists of somewhat vulgar inside jokes. :-) 1.1 Fri Mar 2 03:07:01 PST 2001 - A couple patches from Jonathan Steinert: 'ctcp', 'privmsg', and 'notice' will join() their arguments together with spaces, and 'kick' will no longer accidentally concatenate the nick onto the kick message. Thanks, Jon! 1.0 Wed Feb 21 15:09:56 PST 2001 - Split 'irc_ctcp' messages into 'irc_ctcp' and 'irc_ctcpreply'. My thanks to Jonathan Steinert. - Rocco "dngor" Caputo fixed up my DCC code for me, which was so broken as to exercise POE::Kernel bugs. :-) With his fixes in mind, I rewrote pretty much all the DCC stuff; it's much less hairy now. - Added 'dcc_chat' and 'dcc_accept' commands. - Moved all scripts into the "examples" directory and added a dummy test.pl, so it won't hang during CPAN installations anymore. - Worked around a bug in POE versions <0.1201, which caused DCC SEND/GET connections not to properly respond to pending data. - DCC connections should function properly now. Let me know if you experience problems. 1.0b Sat Jan 13 14:49:22 PST 2001 - This is a beta release. It may not entirely work, and DCC receive is still unimplemented. I'll list the bugs I remember fixing below. 1.0 final will have DCC receive capability, I promise! - CTCP event names are now in the form of "irc_ctcp_ping" or whatever. See the POD documentation. - CTCP events now actually include the sender and recipient names. - The infamous "Not an ARRAY reference" bug should now go away. Make sure you're using a recent version of POE! Turned out it was a bug in POE::Filter::Line. 0.15 Tue Aug 10 19:21:58 EDT 1999 - Well, it sucked for the first revision, at least. In my eager haste, I released the CTCP code with numerous debugging prints scattered throughout the source, some serious brokenness in mixed-mode messages, and a totally unimplemented put() method. All fixed! You can now actually send CTCP messages with the 'ctcp' and 'ctcpreply' events. Now to hack on DCC... 0.14 Sun Aug 8 18:29:46 EDT 1999 - Wrote documentation for POE::Filter::IRC. - Moved Filter.pm to Filter-IRC.pm, in preparation for adding a CTCP filter. - Addi fixed a nasty bug with public/msg handling in the Filter-IRC module. I am SUCH a neen. - Finally sat down and wrote the bloody CTCP filter, at long last. Don't be surprised if it sucks for the first few revisions... the last one I wrote did, too. On the other hand, this uses big chunks of the working code from that effort, so maybe I'll get lucky this time. 0.13 Fri Jun 4 03:56:13 EDT 1999 - Split the parser off into a separate POE::Filter::IRC module. The surgery was surprisingly easy, but I had to do an ugly Makefile.PL hack to get it to install correctly. 0.12 Fri Jun 4 01:16:55 EDT 1999 - Wrote a nice README, finally. - Fixed a bug in the test.pl script where I accidentally referred to the 'irc_disconnected' event as 'irc_disconnect'. No wonder it wasn't shutting down properly. 0.11 Thu Jun 3 18:41:51 EDT 1999 - Spruced up the parser's regexps with a lot of " +"'s. - Turned off all the massively verbose debugging code. - Realized that I need to write a README. 0.1 Thu Jun 3 16:55:24 EDT 1999 - Completely functional, minus CTCP and DCC. 0.1a Mon May 17 09:11:48 EDT 1999 - Released for a little private QA to oznoid and dngor. Moderately functional. Can send every command (I think), and has a half-written parser that handles the most common IRC events, and a few which it wasn't meant to handle. ============================================================================= Key: Qnet == Quakenet MAGnet == MAGnet EFNet == efnet libpoe-component-irc-perl-6.88+dfsg.orig/MANIFEST.SKIP0000644000175000017500000000010312353530642021507 0ustar gregoagregoa^POE-Component-IRC- ^cover_db/ ^utils/developer/ ^xt/ ^README.pod$ libpoe-component-irc-perl-6.88+dfsg.orig/README0000644000175000017500000015461112353530642020507 0ustar gregoagregoaNAME POE::Component::IRC - A fully event-driven IRC client module SYNOPSIS # A simple Rot13 'encryption' bot use strict; use warnings; use POE qw(Component::IRC); my $nickname = 'Flibble' . $$; my $ircname = 'Flibble the Sailor Bot'; my $server = 'irc.perl.org'; my @channels = ('#Blah', '#Foo', '#Bar'); # We create a new PoCo-IRC object my $irc = POE::Component::IRC->spawn( nick => $nickname, ircname => $ircname, server => $server, ) or die "Oh noooo! $!"; POE::Session->create( package_states => [ main => [ qw(_default _start irc_001 irc_public) ], ], heap => { irc => $irc }, ); $poe_kernel->run(); sub _start { my $heap = $_[HEAP]; # retrieve our component's object from the heap where we stashed it my $irc = $heap->{irc}; $irc->yield( register => 'all' ); $irc->yield( connect => { } ); return; } sub irc_001 { my $sender = $_[SENDER]; # Since this is an irc_* event, we can get the component's object by # accessing the heap of the sender. Then we register and connect to the # specified server. my $irc = $sender->get_heap(); print "Connected to ", $irc->server_name(), "\n"; # we join our channels $irc->yield( join => $_ ) for @channels; return; } sub irc_public { my ($sender, $who, $where, $what) = @_[SENDER, ARG0 .. ARG2]; my $nick = ( split /!/, $who )[0]; my $channel = $where->[0]; if ( my ($rot13) = $what =~ /^rot13 (.+)/ ) { $rot13 =~ tr[a-zA-Z][n-za-mN-ZA-M]; $irc->yield( privmsg => $channel => "$nick: $rot13" ); } return; } # We registered for all events, this will produce some debug info. sub _default { my ($event, $args) = @_[ARG0 .. $#_]; my @output = ( "$event: " ); for my $arg (@$args) { if ( ref $arg eq 'ARRAY' ) { push( @output, '[' . join(', ', @$arg ) . ']' ); } else { push ( @output, "'$arg'" ); } } print join ' ', @output, "\n"; return; } DESCRIPTION POE::Component::IRC is a POE component (who'd have guessed?) which acts as an easily controllable IRC client for your other POE components and sessions. You create an IRC component and tell it what events your session cares about and where to connect to, and it sends back interesting IRC events when they happen. You make the client do things by sending it events. That's all there is to it. Cool, no? [Note that using this module requires some familiarity with the details of the IRC protocol. I'd advise you to read up on the gory details of RFC 1459 () before you get started. Keep the list of server numeric codes handy while you program. Needless to say, you'll also need a good working knowledge of POE, or this document will be of very little use to you.] The POE::Component::IRC distribution has a docs/ folder with a collection of salient documentation including the pertinent RFCs. POE::Component::IRC consists of a POE::Session that manages the IRC connection and dispatches "irc_" prefixed events to interested sessions and an object that can be used to access additional information using methods. Sessions register their interest in receiving "irc_" events by sending "register" to the component. One would usually do this in your "_start" handler. Your session will continue to receive events until you "unregister". The component will continue to stay around until you tell it not to with "shutdown". The SYNOPSIS demonstrates a fairly basic bot. See POE::Component::IRC::Cookbook for more examples. Useful subclasses Included with POE::Component::IRC are a number of useful subclasses. As they are subclasses they support all the methods, etc. documented here and have additional methods and quirks which are documented separately: * POE::Component::IRC::State POE::Component::IRC::State provides all the functionality of POE::Component::IRC but also tracks IRC state entities such as nicks and channels. * POE::Component::IRC::Qnet POE::Component::IRC::Qnet is POE::Component::IRC tweaked for use on Quakenet IRC network. * POE::Component::IRC::Qnet::State POE::Component::IRC::Qnet::State is a tweaked version of POE::Component::IRC::State for use on the Quakenet IRC network. The Plugin system As of 3.7, PoCo-IRC sports a plugin system. The documentation for it can be read by looking at POE::Component::IRC::Plugin. That is not a subclass, just a placeholder for documentation! A number of useful plugins have made their way into the core distribution: * POE::Component::IRC::Plugin::DCC Provides DCC support. Loaded by default. * POE::Component::IRC::Plugin::AutoJoin Keeps you on your favorite channels throughout reconnects and even kicks. * POE::Component::IRC::Plugin::Connector Glues an irc bot to an IRC network, i.e. deals with maintaining ircd connections. * POE::Component::IRC::Plugin::BotTraffic Under normal circumstances irc bots do not normal the msgs and public msgs that they generate themselves. This plugin enables you to handle those events. * POE::Component::IRC::Plugin::BotAddressed Generates "irc_bot_addressed" / "irc_bot_mentioned" / "irc_bot_mentioned_action" events whenever your bot's name comes up in channel discussion. * POE::Component::IRC::Plugin::BotCommand Provides an easy way to handle commands issued to your bot. * POE::Component::IRC::Plugin::Console See inside the component. See what events are being sent. Generate irc commands manually. A TCP based console. * POE::Component::IRC::Plugin::FollowTail Follow the tail of an ever-growing file. * POE::Component::IRC::Plugin::Logger Log public and private messages to disk. * POE::Component::IRC::Plugin::NickServID Identify with NickServ when needed. * POE::Component::IRC::Plugin::Proxy A lightweight IRC proxy/bouncer. * POE::Component::IRC::Plugin::CTCP Automagically generates replies to ctcp version, time and userinfo queries. * POE::Component::IRC::Plugin::PlugMan An experimental Plugin Manager plugin. * POE::Component::IRC::Plugin::NickReclaim Automagically deals with your nickname being in use and reclaiming it. * POE::Component::IRC::Plugin::CycleEmpty Cycles (parts and rejoins) channels if they become empty and opless, in order to gain ops. CONSTRUCTORS Both constructors return an object. The object is also available within 'irc_' event handlers by using "$_[SENDER]->get_heap()". See also "register" and "irc_registered". "spawn" Takes a number of arguments, all of which are optional. All the options below may be supplied to the "connect" input event as well, except for 'alias', 'options', 'NoDNS', 'debug', and 'plugin_debug'. * 'alias', a name (kernel alias) that this instance will be known by; * 'options', a hashref containing POE::Session options; * 'Server', the server name; * 'Port', the remote port number; * 'Password', an optional password for restricted servers; * 'Nick', your client's IRC nickname; * 'Username', your client's username; * 'Ircname', some cute comment or something. * 'Bitmode', an integer representing your initial user modes set in the USER command. See RFC 2812. If you do not set this, 8 (+i) will be used. * 'UseSSL', set to some true value if you want to connect using SSL. * 'SSLCert', set to a SSL Certificate(PAM encoded) to connect using a client cert * 'SSLKey', set to a SSL Key(PAM encoded) to connect using a client cert * 'SSLCtx', set to a SSL Context to configure the SSL Connection The 'SSLCert' and 'SSLKey' both need to be specified. The 'SSLCtx' takes precedence specified. * 'Raw', set to some true value to enable the component to send "irc_raw" and "irc_raw_out" events. * 'LocalAddr', which local IP address on a multihomed box to connect as; * 'LocalPort', the local TCP port to open your socket on; * 'NoDNS', set this to 1 to disable DNS lookups using PoCo-Client-DNS. (See note below). * 'Flood', when true, it disables the component's flood protection algorithms, allowing it to send messages to an IRC server at full speed. Disconnects and k-lines are some common side effects of flooding IRC servers, so care should be used when enabling this option. Default is false. Two new attributes are 'Proxy' and 'ProxyPort' for sending your =item * 'Proxy', IP address or server name of a proxy server to use. * 'ProxyPort', which tcp port on the proxy to connect to. * 'NATAddr', what other clients see as your IP address. * 'DCCPorts', an arrayref containing tcp ports that can be used for DCC sends. * 'Resolver', provide a POE::Component::Client::DNS object for the component to use. * 'msg_length', the maximum length of IRC messages, in bytes. Default is 450. The IRC component shortens all messages longer than this value minus the length of your current nickname. IRC only allows raw protocol lines messages that are 512 bytes or shorter, including the trailing "\r\n". This is most relevant to long PRIVMSGs. The IRC component can't be sure how long your user@host mask will be every time you send a message, considering that most networks mangle the 'user' part and some even replace the whole string (think FreeNode cloaks). If you have an unusually long user@host mask you might want to decrease this value if you're prone to sending long messages. Conversely, if you have an unusually short one, you can increase this value if you want to be able to send as long a message as possible. Be careful though, increase it too much and the IRC server might disconnect you with a "Request too long" message when you try to send a message that's too long. * 'debug', if set to a true value causes the IRC component to print every message sent to and from the server, as well as print some warnings when it receives malformed messages. This option will be enabled if the "POCOIRC_DEBUG" environment variable is set to a true value. * 'plugin_debug', set to some true value to print plugin debug info, default 0. Plugins are processed inside an eval. When you enable this option, you will be notified when (and why) a plugin raises an exception. This option will be enabled if the "POCOIRC_DEBUG" environment variable is set to a true value. * 'socks_proxy', specify a SOCKS4/SOCKS4a proxy to use. * 'socks_port', the SOCKS port to use, defaults to 1080 if not specified. * 'socks_id', specify a SOCKS user_id. Default is none. * 'useipv6', enable the use of IPv6 for connections. "spawn" will supply reasonable defaults for any of these attributes which are missing, so don't feel obliged to write them all out. If the component finds that POE::Component::Client::DNS is installed it will use that to resolve the server name passed. Disable this behaviour if you like, by passing: "NoDNS => 1". IRC traffic through a proxy server. 'Proxy''s value should be the IP address or server name of the proxy. 'ProxyPort''s value should be the port on the proxy to connect to. "connect" will default to using the *actual* IRC server's port if you provide a proxy but omit the proxy's port. These are for HTTP Proxies. See 'socks_proxy' for SOCKS4 and SOCKS4a support. For those people who run bots behind firewalls and/or Network Address Translation there are two additional attributes for DCC. 'DCCPorts', is an arrayref of ports to use when initiating DCC connections. 'NATAddr', is the NAT'ed IP address that your bot is hidden behind, this is sent whenever you do DCC. SSL support requires POE::Component::SSLify, as well as an IRC server that supports SSL connections. If you're missing POE::Component::SSLify, specifying 'UseSSL' will do nothing. The default is to not try to use SSL. 'Resolver', requires a POE::Component::Client::DNS object. Useful when spawning multiple poco-irc sessions, saves the overhead of multiple dns sessions. 'NoDNS' has different results depending on whether it is set with "spawn" or "connect". Setting it with "spawn", disables the creation of the POE::Component::Client::DNS completely. Setting it with "connect" on the other hand allows the PoCo-Client-DNS session to be spawned, but will disable any dns lookups using it. SOCKS4 proxy support is provided by 'socks_proxy', 'socks_port' and 'socks_id' parameters. If something goes wrong with the SOCKS connection you should get a warning on STDERR. This is fairly experimental currently. IPv6 support is available for connecting to IPv6 enabled ircds (it won't work for DCC though). To enable it, specify 'useipv6'. Perl >=5.14 or Socket6 (for older Perls) is required. If you that and POE::Component::Client::DNS installed and specify a hostname that resolves to an IPv6 address then IPv6 will be used. If you specify an ipv6 'localaddr' then IPv6 will be used. "new" This method is deprecated. See the "spawn" method instead. The first argument should be a name (kernel alias) which this new connection will be known by. Optionally takes more arguments (see "spawn" as name/value pairs. Returns a POE::Component::IRC object. :) Note: Use of this method will generate a warning. There are currently no plans to make it die() >;] METHODS Information "server" Takes no arguments. Returns the server host we are currently connected to (or trying to connect to). "port" Takes no arguments. Returns the server port we are currently connected to (or trying to connect to). "server_name" Takes no arguments. Returns the name of the IRC server that the component is currently connected to. "server_version" Takes no arguments. Returns the IRC server version. "nick_name" Takes no arguments. Returns a scalar containing the current nickname that the bot is using. "localaddr" Takes no arguments. Returns the IP address being used. "send_queue" The component provides anti-flood throttling. This method takes no arguments and returns a scalar representing the number of messages that are queued up waiting for dispatch to the irc server. "logged_in" Takes no arguments. Returns true or false depending on whether the IRC component is logged into an IRC network. "connected" Takes no arguments. Returns true or false depending on whether the component's socket is currently connected. "disconnect" Takes no arguments. Terminates the socket connection disgracefully >;o] "isupport" Takes one argument, a server capability to query. Returns "undef" on failure or a value representing the applicable capability. A full list of capabilities is available at . "isupport_dump_keys" Takes no arguments, returns a list of the available server capabilities keys, which can be used with "isupport". "resolver" Returns a reference to the POE::Component::Client::DNS object that is internally created by the component. Events "session_id" *Inherited from POE::Component::Syndicator* Takes no arguments. Returns the ID of the component's session. Ideal for posting events to the component. $kernel->post($irc->session_id() => 'mode' => $channel => '+o' => $dude); "session_alias" *Inherited from POE::Component::Syndicator* Takes no arguments. Returns the session alias that has been set through "spawn"'s 'alias' argument. "raw_events" With no arguments, returns true or false depending on whether "irc_raw" and "irc_raw_out" events are being generated or not. Provide a true or false argument to enable or disable this feature accordingly. "yield" *Inherited from POE::Component::Syndicator* This method provides an alternative object based means of posting events to the component. First argument is the event to post, following arguments are sent as arguments to the resultant post. $irc->yield(mode => $channel => '+o' => $dude); "call" *Inherited from POE::Component::Syndicator* This method provides an alternative object based means of calling events to the component. First argument is the event to call, following arguments are sent as arguments to the resultant call. $irc->call(mode => $channel => '+o' => $dude); "delay" *Inherited from POE::Component::Syndicator* This method provides a way of posting delayed events to the component. The first argument is an arrayref consisting of the delayed command to post and any command arguments. The second argument is the time in seconds that one wishes to delay the command being posted. my $alarm_id = $irc->delay( [ mode => $channel => '+o' => $dude ], 60 ); Returns an alarm ID that can be used with "delay_remove" to cancel the delayed event. This will be undefined if something went wrong. "delay_remove" *Inherited from POE::Component::Syndicator* This method removes a previously scheduled delayed event from the component. Takes one argument, the "alarm_id" that was returned by a "delay" method call. my $arrayref = $irc->delay_remove( $alarm_id ); Returns an arrayref that was originally requested to be delayed. "send_event" *Inherited from POE::Component::Syndicator* Sends an event through the component's event handling system. These will get processed by plugins then by registered sessions. First argument is the event name, followed by any parameters for that event. "send_event_next" *Inherited from POE::Component::Syndicator* This sends an event right after the one that's currently being processed. Useful if you want to generate some event which is directly related to another event so you want them to appear together. This method can only be called when POE::Component::IRC is processing an event, e.g. from one of your event handlers. Takes the same arguments as "send_event". "send_event_now" *Inherited from POE::Component::Syndicator* This will send an event to be processed immediately. This means that if an event is currently being processed and there are plugins or sessions which will receive it after you do, then an event sent with "send_event_now" will be received by those plugins/sessions *before* the current event. Takes the same arguments as "send_event". Plugins "pipeline" *Inherited from Object::Pluggable* Returns the Object::Pluggable::Pipeline object. "plugin_add" *Inherited from Object::Pluggable* Accepts two arguments: The alias for the plugin The actual plugin object Any number of extra arguments The alias is there for the user to refer to it, as it is possible to have multiple plugins of the same kind active in one Object::Pluggable object. This method goes through the pipeline's "push()" method, which will call "$plugin->plugin_register($pluggable, @args)". Returns the number of plugins now in the pipeline if plugin was initialized, "undef"/an empty list if not. "plugin_del" *Inherited from Object::Pluggable* Accepts the following arguments: The alias for the plugin or the plugin object itself Any number of extra arguments This method goes through the pipeline's "remove()" method, which will call "$plugin->plugin_unregister($pluggable, @args)". Returns the plugin object if the plugin was removed, "undef"/an empty list if not. "plugin_get" *Inherited from Object::Pluggable* Accepts the following arguments: The alias for the plugin This method goes through the pipeline's "get()" method. Returns the plugin object if it was found, "undef"/an empty list if not. "plugin_list" *Inherited from Object::Pluggable* Takes no arguments. Returns a hashref of plugin objects, keyed on alias, or an empty list if there are no plugins loaded. "plugin_order" *Inherited from Object::Pluggable* Takes no arguments. Returns an arrayref of plugin objects, in the order which they are encountered in the pipeline. "plugin_register" *Inherited from Object::Pluggable* Accepts the following arguments: The plugin object The type of the hook (the hook types are specified with _pluggable_init()'s 'types') The event name[s] to watch The event names can be as many as possible, or an arrayref. They correspond to the prefixed events and naturally, arbitrary events too. You do not need to supply events with the prefix in front of them, just the names. It is possible to register for all events by specifying 'all' as an event. Returns 1 if everything checked out fine, "undef"/an empty list if something is seriously wrong. "plugin_unregister" *Inherited from Object::Pluggable* Accepts the following arguments: The plugin object The type of the hook (the hook types are specified with _pluggable_init()'s 'types') The event name[s] to unwatch The event names can be as many as possible, or an arrayref. They correspond to the prefixed events and naturally, arbitrary events too. You do not need to supply events with the prefix in front of them, just the names. It is possible to register for all events by specifying 'all' as an event. Returns 1 if all the event name[s] was unregistered, undef if some was not found. INPUT EVENTS How to talk to your new IRC component... here's the events we'll accept. These are events that are posted to the component, either via "$poe_kernel->post()" or via the object method "yield". So the following would be functionally equivalent: sub irc_001 { my ($kernel,$sender) = @_[KERNEL,SENDER]; my $irc = $sender->get_heap(); # obtain the poco's object $irc->yield( privmsg => 'foo' => 'Howdy!' ); $kernel->post( $sender => privmsg => 'foo' => 'Howdy!' ); $kernel->post( $irc->session_id() => privmsg => 'foo' => 'Howdy!' ); $kernel->post( $irc->session_alias() => privmsg => 'foo' => 'Howdy!' ); return; } Important Commands "register" *Inherited from POE::Component::Syndicator* Takes N arguments: a list of event names that your session wants to listen for, minus the "irc_" prefix. So, for instance, if you just want a bot that keeps track of which people are on a channel, you'll need to listen for JOINs, PARTs, QUITs, and KICKs to people on the channel you're in. You'd tell POE::Component::IRC that you want those events by saying this: $kernel->post('my client', 'register', qw(join part quit kick)); Then, whenever people enter or leave a channel your bot is on (forcibly or not), your session will receive events with names like "irc_join", "irc_kick", etc., which you can use to update a list of people on the channel. Registering for 'all' will cause it to send all IRC-related events to you; this is the easiest way to handle it. See the test script for an example. Registering will generate an "irc_registered" event that your session can trap. "ARG0" is the components object. Useful if you want to bolt PoCo-IRC's new features such as Plugins into a bot coded to the older deprecated API. If you are using the new API, ignore this :) Registering with multiple component sessions can be tricky, especially if one wants to marry up sessions/objects, etc. Check the SIGNALS section for an alternative method of registering with multiple poco-ircs. Starting with version 4.96, if you spawn the component from inside another POE session, the component will automatically register that session as wanting 'all' irc events. That session will receive an "irc_registered" event indicating that the component is up and ready to go. "unregister" *Inherited from POE::Component::Syndicator* Takes N arguments: a list of event names which you *don't* want to receive. If you've previously done a "register" for a particular event which you no longer care about, this event will tell the IRC connection to stop sending them to you. (If you haven't, it just ignores you. No big deal.) If you have registered with 'all', attempting to unregister individual events such as 'mode', etc. will not work. This is a 'feature'. "connect" Takes one argument: a hash reference of attributes for the new connection, see "spawn" for details. This event tells the IRC client to connect to a new/different server. If it has a connection already open, it'll close it gracefully before reconnecting. "ctcp" and "ctcpreply" Sends a CTCP query or response to the nick(s) or channel(s) which you specify. Takes 2 arguments: the nick or channel to send a message to (use an array reference here to specify multiple recipients), and the plain text of the message to send (the CTCP quoting will be handled for you). The "/me" command in popular IRC clients is actually a CTCP action. # Doing a /me $irc->yield(ctcp => $channel => 'ACTION dances.'); "join" Tells your IRC client to join a single channel of your choice. Takes at least one arg: the channel name (required) and the channel key (optional, for password-protected channels). "kick" Tell the IRC server to forcibly evict a user from a particular channel. Takes at least 2 arguments: a channel name, the nick of the user to boot, and an optional witty message to show them as they sail out the door. "remove" Tell the IRC server to forcibly evict a user from a particular channel. Takes at least 2 arguments: a channel name, the nick of the user to boot, and an optional witty message to show them as they sail out the door. Similar to KICK but does an enforced PART instead. Not supported by all servers. "mode" Request a mode change on a particular channel or user. Takes at least one argument: the mode changes to effect, as a single string (e.g. "#mychan +sm-p+o"), and any number of optional operands to the mode changes (nicks, hostmasks, channel keys, whatever.) Or just pass them all as one big string and it'll still work, whatever. I regret that I haven't the patience now to write a detailed explanation, but serious IRC users know the details anyhow. "nick" Allows you to change your nickname. Takes exactly one argument: the new username that you'd like to be known as. "nickserv" Talks to NickServ, on networks which have it. Takes any number of arguments. "notice" Sends a NOTICE message to the nick(s) or channel(s) which you specify. Takes 2 arguments: the nick or channel to send a notice to (use an array reference here to specify multiple recipients), and the text of the notice to send. "part" Tell your IRC client to leave the channels which you pass to it. Takes any number of arguments: channel names to depart from. If the last argument doesn't begin with a channel name identifier or contains a space character, it will be treated as a PART message and dealt with accordingly. "privmsg" Sends a public or private message to the nick(s) or channel(s) which you specify. Takes 2 arguments: the nick or channel to send a message to (use an array reference here to specify multiple recipients), and the text of the message to send. Have a look at the constants in IRC::Utils if you would like to use formatting and color codes in your messages. $irc->yield('primvsg', '#mychannel', 'Hello there'); # same, but with a green Hello use IRC::Utils qw(GREEN NORMAL); $irc->yield('primvsg', '#mychannel', GREEN.'Hello'.NORMAL.' there'); "quit" Tells the IRC server to disconnect you. Takes one optional argument: some clever, witty string that other users in your channels will see as you leave. You can expect to get an "irc_disconnected" event shortly after sending this. "shutdown" By default, POE::Component::IRC sessions never go away. Even after they're disconnected, they're still sitting around in the background, waiting for you to call "connect" on them again to reconnect. (Whether this behavior is the Right Thing is doubtful, but I don't want to break backwards compatibility at this point.) You can send the IRC session a "shutdown" event manually to make it delete itself. If you are logged into an IRC server, "shutdown" first will send a quit message and wait to be disconnected. It will wait for up to 5 seconds before forcibly disconnecting from the IRC server. If you provide an argument, that will be used as the QUIT message. If you provide two arguments, the second one will be used as the timeout (in seconds). Terminating multiple components can be tricky. Check the SIGNALS section for a method of shutting down multiple poco-ircs. "topic" Retrieves or sets the topic for particular channel. If called with just the channel name as an argument, it will ask the server to return the current topic. If called with the channel name and a string, it will set the channel topic to that string. Supply an empty string to unset a channel topic. "debug" Takes one argument: 0 to turn debugging off or 1 to turn debugging on. This flips the debugging flag in POE::Filter::IRCD, POE::Filter::IRC::Compat, and POE::Component::IRC. This has the same effect as setting Debug in "spawn" or "connect". Not-So-Important Commands "admin" Asks your server who your friendly neighborhood server administrators are. If you prefer, you can pass it a server name to query, instead of asking the server you're currently on. "away" When sent with an argument (a message describig where you went), the server will note that you're now away from your machine or otherwise preoccupied, and pass your message along to anyone who tries to communicate with you. When sent without arguments, it tells the server that you're back and paying attention. "cap" Used to query/enable/disable IRC protocol capabilities. Takes any number of arguments. "dcc*" See the DCC plugin (loaded by default) documentation for DCC-related commands. "info" Basically the same as the "version" command, except that the server is permitted to return any information about itself that it thinks is relevant. There's some nice, specific standards-writing for ya, eh? "invite" Invites another user onto an invite-only channel. Takes 2 arguments: the nick of the user you wish to admit, and the name of the channel to invite them to. "ison" Asks the IRC server which users out of a list of nicknames are currently online. Takes any number of arguments: a list of nicknames to query the IRC server about. "links" Asks the server for a list of servers connected to the IRC network. Takes two optional arguments, which I'm too lazy to document here, so all you would-be linklooker writers should probably go dig up the RFC. "list" Asks the server for a list of visible channels and their topics. Takes any number of optional arguments: names of channels to get topic information for. If called without any channel names, it'll list every visible channel on the IRC network. This is usually a really big list, so don't do this often. "motd" Request the server's "Message of the Day", a document which typically contains stuff like the server's acceptable use policy and admin contact email addresses, et cetera. Normally you'll automatically receive this when you log into a server, but if you want it again, here's how to do it. If you'd like to get the MOTD for a server other than the one you're logged into, pass it the server's hostname as an argument; otherwise, no arguments. "names" Asks the server for a list of nicknames on particular channels. Takes any number of arguments: names of channels to get lists of users for. If called without any channel names, it'll tell you the nicks of everyone on the IRC network. This is a really big list, so don't do this much. "quote" Sends a raw line of text to the server. Takes one argument: a string of a raw IRC command to send to the server. It is more optimal to use the events this module supplies instead of writing raw IRC commands yourself. "stats" Returns some information about a server. Kinda complicated and not terribly commonly used, so look it up in the RFC if you're curious. Takes as many arguments as you please. "time" Asks the server what time it thinks it is, which it will return in a human-readable form. Takes one optional argument: a server name to query. If not supplied, defaults to current server. "trace" If you pass a server name or nick along with this request, it asks the server for the list of servers in between you and the thing you mentioned. If sent with no arguments, it will show you all the servers which are connected to your current server. "users" Asks the server how many users are logged into it. Defaults to the server you're currently logged into; however, you can pass a server name as the first argument to query some other machine instead. "version" Asks the server about the version of ircd that it's running. Takes one optional argument: a server name to query. If not supplied, defaults to current server. "who" Lists the logged-on users matching a particular channel name, hostname, nickname, or what-have-you. Takes one optional argument: a string for it to search for. Wildcards are allowed; in the absence of this argument, it will return everyone who's currently logged in (bad move). Tack an "o" on the end if you want to list only IRCops, as per the RFC. "whois" Queries the IRC server for detailed information about a particular user. Takes any number of arguments: nicknames or hostmasks to ask for information about. As of version 3.2, you will receive an "irc_whois" event in addition to the usual numeric responses. See below for details. "whowas" Asks the server for information about nickname which is no longer connected. Takes at least one argument: a nickname to look up (no wildcards allowed), the optional maximum number of history entries to return, and the optional server hostname to query. As of version 3.2, you will receive an "irc_whowas" event in addition to the usual numeric responses. See below for details. "ping" and "pong" Included for completeness sake. The component will deal with ponging to pings automatically. Don't worry about it. Purely Esoteric Commands "die" Tells the IRC server you're connect to, to terminate. Only useful for IRCops, thank goodness. Takes no arguments. "locops" Opers-only command. This one sends a message to all currently logged-on local-opers (+l). This option is specific to EFNet. "oper" In the exceedingly unlikely event that you happen to be an IRC operator, you can use this command to authenticate with your IRC server. Takes 2 arguments: your username and your password. "operwall" Opers-only command. This one sends a message to all currently logged-on global opers. This option is specific to EFNet. "rehash" Tells the IRC server you're connected to, to rehash its configuration files. Only useful for IRCops. Takes no arguments. "restart" Tells the IRC server you're connected to, to shut down and restart itself. Only useful for IRCops, thank goodness. Takes no arguments. "sconnect" Tells one IRC server (which you have operator status on) to connect to another. This is actually the CONNECT command, but I already had an event called "connect", so too bad. Takes the args you'd expect: a server to connect to, an optional port to connect on, and an optional remote server to connect with, instead of the one you're currently on. "squit" Operator-only command used to disconnect server links. Takes two arguments, the server to disconnect and a message explaining your action. "summon" Don't even ask. "servlist" Lists the currently connected services on the network that are visible to you. Takes two optional arguments, a mask for matching service names against, and a service type. "squery" Sends a message to a service. Takes the same arguments as "privmsg". "userhost" Asks the IRC server for information about particular nicknames. (The RFC doesn't define exactly what this is supposed to return.) Takes any number of arguments: the nicknames to look up. "wallops" Another opers-only command. This one sends a message to all currently logged-on opers (and +w users); sort of a mass PA system for the IRC server administrators. Takes one argument: some clever, witty message to send. OUTPUT EVENTS The events you will receive (or can ask to receive) from your running IRC component. Note that all incoming event names your session will receive are prefixed by "irc_", to inhibit event namespace pollution. If you wish, you can ask the client to send you every event it generates. Simply register for the event name "all". This is a lot easier than writing a huge list of things you specifically want to listen for. FIXME: I'd really like to classify these somewhat ("basic", "oper", "ctcp", "dcc", "raw" or some such), and I'd welcome suggestions for ways to make this easier on the user, if you can think of some. In your event handlers, $_[SENDER] is the particular component session that sent you the event. "$_[SENDER]->get_heap()" will retrieve the component's object. Useful if you want on-the-fly access to the object and its methods. Important Events "irc_registered" *Inherited from POE::Component::Syndicator* Sent once to the requesting session on registration (see "register"). "ARG0" is a reference tothe component's object. "irc_shutdown" *Inherited from POE::Component::Syndicator* Sent to all registered sessions when the component has been asked to "shutdown". "ARG0" will be the session ID of the requesting session. "irc_connected" The IRC component will send an "irc_connected" event as soon as it establishes a connection to an IRC server, before attempting to log in. "ARG0" is the server name. NOTE: When you get an "irc_connected" event, this doesn't mean you can start sending commands to the server yet. Wait until you receive an "irc_001" event (the server welcome message) before actually sending anything back to the server. "irc_ctcp" "irc_ctcp" events are generated upon receipt of CTCP messages, in addition to the "irc_ctcp_*" events mentioned below. They are identical in every way to these, with one difference: instead of the * being in the method name, it is prepended to the argument list. For example, if someone types "/ctcp Flibble foo bar", an "irc_ctcp" event will be sent with 'foo' as "ARG0", and the rest as given below. It is not recommended that you register for both "irc_ctcp" and "irc_ctcp_*" events, since they will both be fired and presumably cause duplication. "irc_ctcp_*" "irc_ctcp_whatever" events are generated upon receipt of CTCP messages. For instance, receiving a CTCP PING request generates an "irc_ctcp_ping" event, CTCP ACTION (produced by typing "/me" in most IRC clients) generates an "irc_ctcp_action" event, blah blah, so on and so forth. "ARG0" is the nick!hostmask of the sender. "ARG1" is the channel/recipient name(s). "ARG2" is the text of the CTCP message. On servers supporting the IDENTIFY-MSG feature (e.g. FreeNode), CTCP ACTIONs will have "ARG3", which will be 1 if the sender has identified with NickServ, 0 otherwise. Note that DCCs are handled separately -- see the DCC plugin. "irc_ctcpreply_*" "irc_ctcpreply_whatever" messages are just like "irc_ctcp_whatever" messages, described above, except that they're generated when a response to one of your CTCP queries comes back. They have the same arguments and such as "irc_ctcp_*" events. "irc_disconnected" The counterpart to "irc_connected", sent whenever a socket connection to an IRC server closes down (whether intentionally or unintentionally). "ARG0" is the server name. "irc_error" You get this whenever the server sends you an ERROR message. Expect this to usually be accompanied by the sudden dropping of your connection. "ARG0" is the server's explanation of the error. "irc_join" Sent whenever someone joins a channel that you're on. "ARG0" is the person's nick!hostmask. "ARG1" is the channel name. "irc_invite" Sent whenever someone offers you an invitation to another channel. "ARG0" is the person's nick!hostmask. "ARG1" is the name of the channel they want you to join. "irc_kick" Sent whenever someone gets booted off a channel that you're on. "ARG0" is the kicker's nick!hostmask. "ARG1" is the channel name. "ARG2" is the nick of the unfortunate kickee. "ARG3" is the explanation string for the kick. "irc_mode" Sent whenever someone changes a channel mode in your presence, or when you change your own user mode. "ARG0" is the nick!hostmask of that someone. "ARG1" is the channel it affects (or your nick, if it's a user mode change). "ARG2" is the mode string (i.e., "+o-b"). The rest of the args ("ARG3 .. $#_") are the operands to the mode string (nicks, hostmasks, channel keys, whatever). "irc_msg" Sent whenever you receive a PRIVMSG command that was addressed to you privately. "ARG0" is the nick!hostmask of the sender. "ARG1" is an array reference containing the nick(s) of the recipients. "ARG2" is the text of the message. On servers supporting the IDENTIFY-MSG feature (e.g. FreeNode), there will be an additional argument, "ARG3", which will be 1 if the sender has identified with NickServ, 0 otherwise. "irc_nick" Sent whenever you, or someone around you, changes nicks. "ARG0" is the nick!hostmask of the changer. "ARG1" is the new nick that they changed to. "irc_notice" Sent whenever you receive a NOTICE command. "ARG0" is the nick!hostmask of the sender. "ARG1" is an array reference containing the nick(s) or channel name(s) of the recipients. "ARG2" is the text of the NOTICE message. "irc_part" Sent whenever someone leaves a channel that you're on. "ARG0" is the person's nick!hostmask. "ARG1" is the channel name. "ARG2" is the part message. "irc_public" Sent whenever you receive a PRIVMSG command that was sent to a channel. "ARG0" is the nick!hostmask of the sender. "ARG1" is an array reference containing the channel name(s) of the recipients. "ARG2" is the text of the message. On servers supporting the IDENTIFY-MSG feature (e.g. FreeNode), there will be an additional argument, "ARG3", which will be 1 if the sender has identified with NickServ, 0 otherwise. "irc_quit" Sent whenever someone on a channel with you quits IRC (or gets KILLed). "ARG0" is the nick!hostmask of the person in question. "ARG1" is the clever, witty message they left behind on the way out. "irc_socketerr" Sent when a connection couldn't be established to the IRC server. "ARG0" is probably some vague and/or misleading reason for what failed. "irc_topic" Sent when a channel topic is set or unset. "ARG0" is the nick!hostmask of the sender. "ARG1" is the channel affected. "ARG2" will be either: a string if the topic is being set; or a zero-length string (i.e. '') if the topic is being unset. Note: replies to queries about what a channel topic *is* (i.e. TOPIC #channel), are returned as numerics, not with this event. "irc_whois" Sent in response to a WHOIS query. "ARG0" is a hashref, with the following keys: * 'nick', the users nickname; * 'user', the users username; * 'host', their hostname; * 'real', their real name; * 'idle', their idle time in seconds; * 'signon', the epoch time they signed on (will be undef if ircd does not support this); * 'channels', an arrayref listing visible channels they are on, the channel is prefixed with '@','+','%' depending on whether they have +o +v or +h; * 'server', their server (might not be useful on some networks); * 'oper', whether they are an IRCop, contains the IRC operator string if they are, undef if they aren't. * 'actually', some ircds report the user's actual ip address, that'll be here; * 'identified'. if the user has identified with NICKSERV (ircu, seven, Plexus) * 'modes', a string describing the user's modes (Rizon) "irc_whowas" Similar to the above, except some keys will be missing. "irc_raw" Enabled by passing "Raw => 1" to "spawn" or "connect", or by calling "raw_events" with a true argument. "ARG0" is the raw IRC string received by the component from the IRC server, before it has been mangled by filters and such like. "irc_raw_out" Enabled by passing "Raw => 1" to "spawn" or "connect", or by calling "raw_events" with a true argument. "ARG0" is the raw IRC string sent by the component to the the IRC server. "irc_isupport" Emitted by the first event after an "irc_005", to indicate that isupport information has been gathered. "ARG0" is the POE::Component::IRC::Plugin::ISupport object. "irc_socks_failed" Emitted whenever we fail to connect successfully to a SOCKS server or the SOCKS server is not actually a SOCKS server. "ARG0" will be some vague reason as to what went wrong. Hopefully. "irc_socks_rejected" Emitted whenever a SOCKS connection is rejected by a SOCKS server. "ARG0" is the SOCKS code, "ARG1" the SOCKS server address, "ARG2" the SOCKS port and "ARG3" the SOCKS user id (if defined). "irc_plugin_add" *Inherited from Object::Pluggable* Emitted whenever a new plugin is added to the pipeline. "ARG0" is the plugin alias. "ARG1" is the plugin object. "irc_plugin_del" *Inherited from Object::Pluggable* Emitted whenever a plugin is removed from the pipeline. "ARG0" is the plugin alias. "ARG1" is the plugin object. "irc_plugin_error" *Inherited from Object::Pluggable* Emitted when an error occurs while executing a plugin handler. "ARG0" is the error message. "ARG1" is the plugin alias. "ARG2" is the plugin object. Somewhat Less Important Events "irc_cap" A reply from the server regarding protocol capabilities. "ARG0" is the CAP subcommand (e.g. 'LS'). "ARG1" is the result of the subcommand, unless this is a multi-part reply, in which case "ARG1" is '*' and "ARG2" contains the result. "irc_dcc_*" See the DCC plugin (loaded by default) documentation for DCC-related events. "irc_ping" An event sent whenever the server sends a PING query to the client. (Don't confuse this with a CTCP PING, which is another beast entirely. If unclear, read the RFC.) Note that POE::Component::IRC will automatically take care of sending the PONG response back to the server for you, although you can still register to catch the event for informational purposes. "irc_snotice" A weird, non-RFC-compliant message from an IRC server. Usually sent during to you during an authentication phase right after you connect, while the server does a hostname lookup or similar tasks. "ARG0" is the text of the server's message. "ARG1" is the target, which could be '*' or 'AUTH' or whatever. Servers vary as to whether these notices include a server name as the sender, or no sender at all. "ARG1" is the sender, if any. "irc_delay_set" *Inherited from POE::Component::Syndicator* Emitted on a successful addition of a delayed event using the "delay" method. "ARG0" will be the alarm_id which can be used later with "delay_remove". Subsequent parameters are the arguments that were passed to "delay". "irc_delay_removed" *Inherited from POE::Component::Syndicator* Emitted when a delayed command is successfully removed. "ARG0" will be the alarm_id that was removed. Subsequent parameters are the arguments that were passed to "delay". All numeric events Most messages from IRC servers are identified only by three-digit numeric codes with undescriptive constant names like RPL_UMODEIS and ERR_NOTOPLEVEL. (Actually, the list of codes in the RFC is kind of out-of-date... the list in the back of Net::IRC::Event.pm is more complete, and different IRC networks have different and incompatible lists. Ack!) As an example, say you wanted to handle event 376 (RPL_ENDOFMOTD, which signals the end of the MOTD message). You'd register for '376', and listen for "irc_376" events. Simple, no? "ARG0" is the name of the server which sent the message. "ARG1" is the text of the message. "ARG2" is an array reference of the parsed message, so there is no need to parse "ARG1" yourself. SIGNALS The component will handle a number of custom signals that you may send using POE::Kernel's "signal" method. "POCOIRC_REGISTER" *Inherited from POE::Component::Syndicator* Registering with multiple PoCo-IRC components has been a pita. Well, no more, using the power of POE::Kernel signals. If the component receives a "POCOIRC_REGISTER" signal it'll register the requesting session and trigger an "irc_registered" event. From that event one can get all the information necessary such as the poco-irc object and the SENDER session to do whatever one needs to build a poco-irc dispatch table. The way the signal handler in PoCo-IRC is written also supports sending the "POCOIRC_REGISTER" to multiple sessions simultaneously, by sending the signal to the POE Kernel itself. Pass the signal your session, session ID or alias, and the IRC events (as specified to "register"). To register with multiple PoCo-IRCs one can do the following in your session's _start handler: sub _start { my ($kernel, $session) = @_[KERNEL, SESSION]; # Registering with multiple pocoircs for 'all' IRC events $kernel->signal($kernel, 'POCOIRC_REGISTER', $session->ID(), 'all'); return: } Each poco-irc will send your session an "irc_registered" event: sub irc_registered { my ($kernel, $sender, $heap, $irc_object) = @_[KERNEL, SENDER, HEAP, ARG0]; # Get the poco-irc session ID my $sender_id = $sender->ID(); # Or it's alias my $poco_alias = $irc_object->session_alias(); # Store it in our heap maybe $heap->{irc_objects}->{ $sender_id } = $irc_object; # Make the poco connect $irc_object->yield(connect => { }); return; } "POCOIRC_SHUTDOWN" *Inherited from POE::Component::Syndicator* Telling multiple poco-ircs to shutdown was a pita as well. The same principle as with registering applies to shutdown too. Send a "POCOIRC_SHUTDOWN" to the POE Kernel to terminate all the active poco-ircs simultaneously. $poe_kernel->signal($poe_kernel, 'POCOIRC_SHUTDOWN'); Any additional parameters passed to the signal will become your quit messages on each IRC network. ENCODING This can be an issue. Take a look at IRC::Utils' section on it. BUGS A few have turned up in the past and they are sure to again. Please use to report any. Alternatively, email the current maintainer. DEVELOPMENT You can find the latest source on github: The project's developers usually hang out in the "#poe" IRC channel on irc.perl.org. Do drop us a line. MAINTAINERS Chris "BinGOs" Williams Hinrik Örn Sigurðsson AUTHOR Dennis Taylor. LICENCE Copyright (c) Dennis Taylor, Chris Williams and Hinrik Örn Sigurðsson This module may be used, modified, and distributed under the same terms as Perl itself. Please see the license that came with your Perl distribution for details. MAD PROPS The maddest of mad props go out to Rocco "dngor" Caputo , for inventing something as mind-bogglingly cool as POE, and to Kevin "oznoid" Lenzo , for being the attentive parent of our precocious little infobot on #perl. Further props to a few of the studly bughunters who made this module not suck: Abys , Addi , ResDev , and Roderick . Woohoo! Kudos to Apocalypse, , for the plugin system and to Jeff 'japhy' Pinyan, , for Pipeline. Thanks to the merry band of POE pixies from #PoE @ irc.perl.org, including ( but not limited to ), ketas, ct, dec, integral, webfox, immute, perigrin, paulv, alias. IP functions are shamelessly 'borrowed' from Net::IP by Manuel Valente Check out the Changes file for further contributors. SEE ALSO RFC 1459 , , , Some good examples reside in the POE cookbook which has a whole section devoted to IRC programming . The examples/ folder of this distribution. libpoe-component-irc-perl-6.88+dfsg.orig/t/0000755000175000017500000000000012354017166020064 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/0000755000175000017500000000000012354017166022050 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/13_botcommand/0000755000175000017500000000000012354017166024476 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/13_botcommand/01_load.t0000644000175000017500000000216512353530642026104 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::BotCommand->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::BotCommand'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::BotCommand'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::BotCommand'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/13_botcommand/06_prefix.t0000644000175000017500000000752312353530642026472 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 18; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_botcmd_cmd1 irc_botcmd_cmd2 irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new( Addressed => 0, Prefix => '(', # regex metacharacter should not cause issues Commands => { cmd1 => 'First test command', foo => 'This will get removed', }, ); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with two commands'); ok($plugin->add(cmd2 => 'Second test command'), 'Add another command'); ok($plugin->remove('foo'), 'Remove command'); my %cmds = $plugin->list(); is(keys %cmds, 2, 'Correct number of commands'); ok($cmds{cmd1}, 'First command is present'); ok($cmds{cmd2}, 'Second command is present'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; # try command $bot2->yield(privmsg => $where, "(cmd1 foo bar"); # and one with color $bot2->yield(privmsg => $where, "\x02(cmd2\x0f"); } sub irc_botcmd_cmd1 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Normal command (user)'); is($where, '#testchannel', 'Normal command (channel)'); is($args, 'foo bar', 'Normal command (arguments)'); } sub irc_botcmd_cmd2 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Colored command (user)'); is($where, '#testchannel', 'Colored command (channel)'); ok(!defined $args, 'Colored command (arguments)'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/13_botcommand/02_commands.t0000644000175000017500000001137712353530642026774 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 22; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_botcmd_cmd1 irc_botcmd_cmd2 irc_botcmd_cmd3 irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new( Commands => { cmd1 => 'First test command', cmd2 => { info => 'First test command with argument count checking', args => [qw(test_arg test_arg2)], variable => 1, test_arg => ['Description of first arg', qw(value1 value2)], test_arg2 => 'Description of second arg', optional_arg => 'Description of optional arg', }, foo => 'This will get removed', }, ); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with three commands'); ok($plugin->add(cmd3 => 'Third test command'), 'Add another command'); ok($plugin->remove('foo'), 'Remove command'); my %cmds = $plugin->list(); is(keys %cmds, 3, 'Correct number of commands'); ok($cmds{cmd1}, 'First command is present'); ok($cmds{cmd2}, 'Second command is present'); ok($cmds{cmd3}, 'Third command is present'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; # try command $bot2->yield(privmsg => $where, "TestBot1: cmd1 foo bar"); # try command with predefined arguments $bot2->yield(privmsg => $where, "TestBot1: cmd2 value1 bar opt_arg"); # and one with color $bot2->yield(privmsg => $where, "\x0302TestBot1\x0f: \x02cmd3\x0f"); } sub irc_botcmd_cmd1 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Normal command (user)'); is($where, '#testchannel', 'Normal command (channel)'); is($args, 'foo bar', 'Normal command (arguments)'); } sub irc_botcmd_cmd2 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Command with args (user)'); is($where, '#testchannel', 'Command with args (channel)'); is_deeply($args, { test_arg => 'value1', test_arg2 => 'bar', opt0 => 'opt_arg'}, 'Command with args (arguments)'); } sub irc_botcmd_cmd3 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Colored command (user)'); is($where, '#testchannel', 'Colored command (channel)'); ok(!defined $args, 'Colored command (arguments)'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/13_botcommand/07_bare_private.t0000644000175000017500000000745712353530642027647 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 18; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_botcmd_cmd1 irc_botcmd_cmd2 irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new( Bare_private => 1, Commands => { cmd1 => 'First test command', foo => 'This will get removed', }, ); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with two commands'); ok($plugin->add(cmd2 => 'Second test command'), 'Add another command'); ok($plugin->remove('foo'), 'Remove command'); my %cmds = $plugin->list(); is(keys %cmds, 2, 'Correct number of commands'); ok($cmds{cmd1}, 'First command is present'); ok($cmds{cmd2}, 'Second command is present'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; # try command $bot2->yield(privmsg => $bot1->nick_name(), "cmd1 foo bar"); # and one with color $bot2->yield(privmsg => $bot1->nick_name(), "\x02cmd2\x0f"); } sub irc_botcmd_cmd1 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Normal command (user)'); is($where, $bot2->nick_name(), 'Normal command (channel)'); is($args, 'foo bar', 'Normal command (arguments)'); } sub irc_botcmd_cmd2 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Colored command (user)'); is($where, $bot2->nick_name(), 'Colored command (channel)'); ok(!defined $args, 'Colored command (arguments)'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/13_botcommand/04_help.t0000644000175000017500000001037512353530642026122 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 25; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_notice irc_disconnected )], ], ); my @bar_help = ( "Syntax: TestBot1: bar arg1 arg2 ...", "Description: Test command2", "Arguments:", " arg1: What to bar (table|chair)", " arg2: Where to bar" ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new(); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with no commands'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; $bot2->yield(privmsg => $where, "TestBot1: help"); $bot2->yield(privmsg => $where, "TestBot1: help foo"); } sub irc_notice { my ($sender, $heap, $who, $where, $what) = @_[SENDER, HEAP, ARG0..ARG2]; my $irc = $sender->get_heap(); my $nick = (split /!/, $who)[0]; return if $irc != $bot2; $heap->{replies}++; ## no critic (ControlStructures::ProhibitCascadingIfElse) if ($heap->{replies} == 1) { is($nick, $bot1->nick_name(), 'Bot nickname'); like($what, qr/^No commands/, 'Bot reply'); } elsif ($heap->{replies} == 2) { is($nick, $bot1->nick_name(), 'Bot nickname'); like($what, qr/^Unknown command:/, 'Bot reply'); my ($p) = grep { $_->isa('POE::Component::IRC::Plugin::BotCommand') } values %{ $bot1->plugin_list() }; ok($p->add(foo => 'Test command'), 'Add command foo'); ok($p->add(bar => { info => 'Test command2', args => [qw(arg1 arg2)], arg1 => ['What to bar', qw(table chair)], arg2 => 'Where to bar', variable => 1, }), 'Add command bar'); $irc->yield(privmsg => $where, "TestBot1: help"); $irc->yield(privmsg => $where, "TestBot1: help bar"); } elsif ($heap->{replies} == 4) { is($nick, $bot1->nick_name(), 'Bot nickname'); like($what, qr/^Commands: bar, foo/, 'Bot reply'); } elsif ($heap->{replies} >= 6 && $heap->{replies} <= 11) { is($nick, $bot1->nick_name(), 'Bot nickname'); is($what, shift @bar_help, 'Command with args help'); $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/13_botcommand/05_auth_sub.t0000644000175000017500000000722312353530642027003 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 14; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_notice irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new( Auth_sub => sub { return 1 if $_[3] eq 'help'; return 0; } ); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with no commands'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; $bot2->yield(privmsg => $where, "TestBot1: help"); $bot2->yield(privmsg => $where, "TestBot1: help foo"); } sub irc_notice { my ($sender, $heap, $who, $where, $what) = @_[SENDER, HEAP, ARG0..ARG2]; my $irc = $sender->get_heap(); my $nick = (split /!/, $who)[0]; return if $irc != $bot2; $heap->{replies}++; ## no critic (ControlStructures::ProhibitCascadingIfElse) if ($heap->{replies} == 1) { is($nick, $bot1->nick_name(), 'Bot nickname'); like($what, qr/^No commands/, 'Bot reply'); } elsif ($heap->{replies} == 2) { is($nick, $bot1->nick_name(), 'Bot nickname'); like($what, qr/^Unknown command:/, 'Bot reply'); my ($p) = grep { $_->isa('POE::Component::IRC::Plugin::BotCommand') } values %{ $bot1->plugin_list() }; ok($p->add(foo => 'Test command'), 'Add command foo'); $irc->yield(privmsg => $where, "TestBot1: hlagh"); } elsif ($heap->{replies} == 4) { is($nick, $bot1->nick_name(), 'Bot nickname'); like($what, qr/^You are not authorized/, 'Bot reply'); $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/13_botcommand/08_nonword.t0000644000175000017500000000766112353530642026670 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 18; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected )], main => { 'irc_botcmd_cmd-1' => 'irc_botcmd_cmd1', 'irc_botcmd_cmd-2' => 'irc_botcmd_cmd2', }, ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new( Addressed => 0, Prefix => '(', # regex metacharacter should not cause issues Commands => { 'cmd-1' => 'First test command', foo => 'This will get removed', }, ); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with two commands'); ok($plugin->add('cmd-2', 'Second test command'), 'Add another command'); ok($plugin->remove('foo'), 'Remove command'); my %cmds = $plugin->list(); is(keys %cmds, 2, 'Correct number of commands'); ok($cmds{'cmd-1'}, 'First command is present'); ok($cmds{'cmd-2'}, 'Second command is present'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; # try command $bot2->yield(privmsg => $where, "(cmd-1 foo bar"); # and one with color $bot2->yield(privmsg => $where, "\x02(cmd-2\x0f"); } sub irc_botcmd_cmd1 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Normal command (user)'); is($where, '#testchannel', 'Normal command (channel)'); is($args, 'foo bar', 'Normal command (arguments)'); } sub irc_botcmd_cmd2 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Colored command (user)'); is($where, '#testchannel', 'Colored command (channel)'); ok(!defined $args, 'Colored command (arguments)'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/13_botcommand/03_options.t0000644000175000017500000001013412353530642026655 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 18; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); { package TestPlugin; use POE::Component::IRC::Plugin 'PCI_EAT_NONE'; use Test::More; use strict; use warnings; sub new { bless {}, shift } sub PCI_register { $_[1]->plugin_register($_[0], 'SERVER', 'public'); 1 } sub PCI_unregister { 1 } sub S_public { fail("Shouldn't get irc_public event"); PCI_EAT_NONE; } } POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_botcmd_cmd1 irc_botcmd_cmd2 irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new( Commands => { cmd1 => 'First test command', foo => 'This will get removed', }, Addressed => 0, Prefix => ',', Eat => 1, ); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with two commands'); $irc->plugin_add(TestPlugin => TestPlugin->new()); ok($plugin->add(cmd2 => 'Second test command'), 'Add another command'); ok($plugin->remove('foo'), 'Remove one command'); my %cmds = $plugin->list(); is(keys %cmds, 2, 'Correct number of commands'); ok($cmds{cmd1}, 'First command is present'); ok($cmds{cmd2}, 'Second command is present'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; $bot2->yield(privmsg => $where, ",cmd1 foo bar"); $bot2->yield(privmsg => $where, ",cmd2"); } sub irc_botcmd_cmd1 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'cmd1 user'); is($where, '#testchannel', 'cmd1 channel'); is($args, 'foo bar', 'cmd1 arguments'); } sub irc_botcmd_cmd2 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'cmd2 user'); is($where, '#testchannel', 'cmd2 channel'); ok(!defined $args, 'cmd1 arguments'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/09_nickreclaim/0000755000175000017500000000000012354017166024641 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/09_nickreclaim/01_load.t0000644000175000017500000000217212353530642026245 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::NickReclaim; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::NickReclaim->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::NickReclaim'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::NickReclaim'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::NickReclaim'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/09_nickreclaim/04_immediate_quit.t0000644000175000017500000000617712353530642030342 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::NickReclaim; use POE::Component::Server::IRC; use Test::More tests => 8; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, alias => 'bot1', ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, alias => 'bot2', ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(NickReclaim => POE::Component::IRC::Plugin::NickReclaim->new( poll => 65, # longer than the test timeout )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_433 irc_join irc_nick irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $heap->{port} = $port; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->session_alias() . ' (nick=' . $irc->nick_name() .') logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass($irc->session_alias().' (nick='.$irc->nick_name().") joined $where"); if ($irc == $bot1) { $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $_[HEAP]->{port}, }); } else { $bot1->yield('quit'); } } sub irc_433 { my $irc = $_[SENDER]->get_heap(); pass($irc->session_alias . ' (nick=' . $irc->nick_name() .') nick collision'); } sub irc_nick { my ($sender, $new_nick) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); return if $irc != $bot2 || $new_nick ne 'TestBot1'; pass($irc->session_alias().' (nick='.$irc->nick_name().') reclaimed nick'); $irc->yield('quit'); } sub irc_disconnected { my ($kernel, $sender, $heap) = @_[KERNEL, SENDER, HEAP]; my $irc = $sender->get_heap(); pass($irc->session_alias . ' (nick=' . $irc->nick_name() .') disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/09_nickreclaim/03_immediate_change.t0000644000175000017500000000650412353530642030576 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::NickReclaim; use POE::Component::Server::IRC; use Test::More tests => 9; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, alias => 'bot1', ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, alias => 'bot2', ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(NickReclaim => POE::Component::IRC::Plugin::NickReclaim->new( poll => 65, # longer than the test timeout )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_433 irc_join irc_nick irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $heap->{port} = $port; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->session_alias() . ' (nick=' . $irc->nick_name() .') logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass($irc->session_alias().' (nick='.$irc->nick_name().") joined $where"); if ($irc == $bot1) { $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $_[HEAP]->{port}, }); } else { $bot1->yield(nick => 'TestBot2'); } } sub irc_433 { my $irc = $_[SENDER]->get_heap(); pass($irc->session_alias . ' (nick=' . $irc->nick_name() .') nick collision'); } sub irc_nick { my ($sender, $new_nick) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); if ($irc == $bot1 && $new_nick eq 'TestBot2') { pass($irc->session_alias().' (nick='.$irc->nick_name().') changed nicks'); } elsif ($irc == $bot2 && $new_nick eq 'TestBot1') { pass($irc->session_alias().' (nick='.$irc->nick_name().') reclaimed nick'); $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_disconnected { my ($kernel, $sender, $heap) = @_[KERNEL, SENDER, HEAP]; my $irc = $sender->get_heap(); pass($irc->session_alias . ' (nick=' . $irc->nick_name() .') disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/09_nickreclaim/02_reclaim.t0000644000175000017500000000526412353530642026750 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::NickReclaim; use POE::Component::Server::IRC; use Test::More tests => 6; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, alias => 'bot1', ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, alias => 'bot2', ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(NickReclaim => POE::Component::IRC::Plugin::NickReclaim->new( poll => 1, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_433 irc_nick irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $heap->{port} = $port; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->session_alias() . ' (nick=' . $irc->nick_name() .') logged in'); return if $irc != $bot1; $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $_[HEAP]->{port}, }); } sub irc_433 { my $irc = $_[SENDER]->get_heap(); pass($irc->session_alias . ' (nick=' . $irc->nick_name() .') nick collision'); $bot1->yield('quit'); } sub irc_nick { my ($sender, $new_nick) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); is($new_nick, 'TestBot1', $irc->session_alias . ' reclaimed nick ' . $irc->nick_name()); $irc->yield('quit'); } sub irc_disconnected { my ($kernel, $sender, $heap) = @_[KERNEL, SENDER, HEAP]; my $irc = $sender->get_heap(); pass($irc->session_alias . ' (nick=' . $irc->nick_name() .') disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/05_isupport/0000755000175000017500000000000012354017166024241 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/05_isupport/01_load.t0000644000175000017500000000215312353530642025644 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::ISupport; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::ISupport->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::ISupport'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::ISupport'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::ISupport'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/05_isupport/02_isupport.t0000644000175000017500000000364512353530642026622 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 5; my $bot = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_isupport irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); } sub irc_isupport { my ($sender, $heap, $plugin) = @_[SENDER, HEAP, ARG0]; my $irc = $sender->get_heap(); return if $heap->{got_isupport}; $heap->{got_isupport}++; pass('irc_isupport'); isa_ok($plugin, 'POE::Component::IRC::Plugin::ISupport'); my @keys = $plugin->isupport_dump_keys(); ok($plugin->isupport(pop @keys), "Queried a parameter"); $irc->yield('quit'); } sub irc_disconnected { my ($kernel) = $_[KERNEL]; pass('irc_disconnected'); $kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/07_console/0000755000175000017500000000000012354017166024020 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/07_console/01_load.t0000644000175000017500000000214612353530642025425 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::Console; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::Console->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::Console'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Console'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Console'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/11_cycleempty/0000755000175000017500000000000012354017166024527 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/11_cycleempty/02_cycle.t0000644000175000017500000000607112353530642026316 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::CycleEmpty; use POE::Component::Server::IRC; use Test::More tests => 10; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); my $plugin = POE::Component::IRC::Plugin::CycleEmpty->new(); $bot2->plugin_add(CycleEmpty => $plugin); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_part irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name . ' logged in'); $irc->yield(join => '#testchannel') if $irc == $bot1; } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); if (!$heap->{joined} || $heap->{joined} != 2) { $heap->{joined}++; pass("$nick joined channel"); $bot2->yield(join => $where) if $irc == $bot1; } if ($irc == $bot2) { $bot1->yield(part => $where); if ($heap->{cycling}) { pass("$nick rejoined channel"); $bot1->yield('quit'); $bot2->yield('quit'); } } } sub irc_part { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass("$nick parted channel"); if ($irc == $bot2) { ok($plugin->is_cycling($where), "$nick is cycling"); $heap->{cycling} = 1; } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/11_cycleempty/01_load.t0000644000175000017500000000220312353530642026126 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::CycleEmpty; my $bot = POE::Component::IRC::State->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::CycleEmpty->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::CycleEmpty'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::CycleEmpty'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::CycleEmpty'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/01_ctcp/0000755000175000017500000000000012354017166023301 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/01_ctcp/01_load.t0000644000175000017500000000212712353530642024705 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::CTCP; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::CTCP->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::CTCP'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::CTCP'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::CTCP'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/01_ctcp/02_replies.t0000644000175000017500000000712512353530642025435 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::CTCP; use POE::Component::Server::IRC; use Test::More tests => 8; my $bot = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot->plugin_add(CTCP => POE::Component::IRC::Plugin::CTCP->new( version => 'Test version', userinfo => 'Test userinfo', clientinfo => 'Test clientinfo', source => 'Test source', )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_disconnected irc_ctcpreply_version irc_ctcpreply_userinfo irc_ctcpreply_clientinfo irc_ctcpreply_source irc_ctcpreply_ping irc_ctcpreply_time )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(ctcp => $irc->nick_name(), 'VERSION'); $irc->yield(ctcp => $irc->nick_name(), 'USERINFO'); $irc->yield(ctcp => $irc->nick_name(), 'CLIENTINFO'); $irc->yield(ctcp => $irc->nick_name(), 'SOURCE'); $irc->yield(ctcp => $irc->nick_name(), 'PING test'); $irc->yield(ctcp => $irc->nick_name(), 'TIME'); } sub irc_ctcpreply_version { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; $heap->{replies}++; is($msg, 'Test version', 'CTCP VERSION reply'); $sender->get_heap()->yield('quit') if $heap->{replies} == 6; } sub irc_ctcpreply_userinfo { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; $heap->{replies}++; is($msg, 'Test userinfo', 'CTCP USERINFO reply'); $sender->get_heap()->yield('quit') if $heap->{replies} == 6; } sub irc_ctcpreply_clientinfo { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; $heap->{replies}++; is($msg, 'Test clientinfo', 'CTCP CLIENTINFO reply'); $sender->get_heap()->yield('quit') if $heap->{replies} == 6; } sub irc_ctcpreply_source { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; $heap->{replies}++; is($msg, 'Test source', 'CTCP SOURCE reply'); $sender->get_heap()->yield('quit') if $heap->{replies} == 6; } sub irc_ctcpreply_ping { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; $heap->{replies}++; is($msg, 'test', 'CTCP PING reply'); $sender->get_heap()->yield('quit') if $heap->{replies} == 6; } sub irc_ctcpreply_time { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; $heap->{replies}++; ok(length $msg, 'CTCP TIME reply'); $sender->get_heap()->yield('quit') if $heap->{replies} == 6; } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/12_autojoin/0000755000175000017500000000000012354017166024202 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/12_autojoin/03_banned.t0000644000175000017500000000577412353530642026133 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 9; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new( Retry_when_banned => 1, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_chan_mode irc_474 )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name.' logged in'); if ($irc == $bot1) { $irc->yield(join => '#testchannel'); } } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', $irc->nick_name. ' joined channel'); if ($nick eq 'TestBot1') { $irc->yield(mode => $where, '+b TestBot2!*@*'); } else { $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_chan_mode { my ($chan, $mode) = @_[ARG1, ARG2]; if ($mode eq '+b') { pass('Ban set'); $bot2->yield(join => $chan); } elsif ($mode eq '-b') { pass('Ban removed'); } } sub irc_474 { my ($chan) = $_[ARG2]->[0]; if (!$_[HEAP]->{denied}) { pass("Can't join due to ban"); $bot1->yield(mode => $chan, '-b TestBot2!*@*'); $_[HEAP]->{denied} = 1; } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $bot1->yield('shutdown'); $bot2->yield('shutdown'); $ircd->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/12_autojoin/02_join.t0000644000175000017500000000373412353530642025634 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 4; my $bot = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot->plugin_add(AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new( Channels => ['#chan1', '#chan2'], )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); } sub irc_join { my ($sender, $heap, $where) = @_[SENDER, HEAP, ARG1]; my $irc = $sender->get_heap(); $heap->{joined}++; $where =~ /^#chan[12]$/ ? pass("Joined channel $where") : fail("Joined wrong channel $where"); ; $irc->yield('quit') if $heap->{joined} == 2; } sub irc_disconnected { my ($kernel) = $_[KERNEL]; pass('irc_disconnected'); $kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $bot->yield('shutdown'); $ircd->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/12_autojoin/05_password.t0000644000175000017500000000667412353530642026550 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 10; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new( Channels => { '#testchannel' => 'secret' }, RejoinOnKick => 1, Rejoin_delay => 1, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_chan_mode irc_kick )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $heap->{port} = $port; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); if ($irc == $bot1) { $irc->yield(join => '#testchannel'); } } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', "$nick joined $where"); if ($nick eq 'TestBot1') { $bot1->yield(mode => $where, '+k secret'); } else { $heap->{bot2_joined}++; if ($heap->{bot2_joined} == 1) { $bot1->yield(mode => $where, '+k topsecret'); } else { $bot1->yield('quit'); $bot2->yield('quit'); } } } sub irc_chan_mode { my ($heap, $where, $mode) = @_[HEAP, ARG1, ARG2]; return if $bot1 != $_[SENDER]->get_heap(); if ($mode eq '+k') { pass("$where key set"); $heap->{key_set}++; if ($heap->{key_set} == 1) { $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $heap->{port}, }); } else { $bot1->yield(kick => $where, 'TestBot2'); } } } sub irc_kick { my ($sender, $where, $victim) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $victim ne $irc->nick_name(); pass("$victim kicked from $where"); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/12_autojoin/01_load.t0000644000175000017500000000215312353530642025605 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::AutoJoin; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::AutoJoin->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::AutoJoin'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::AutoJoin'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::AutoJoin'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/12_autojoin/06_kick_ban_password.t0000644000175000017500000001027512353530642030362 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 17; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new( Channels => { '#testchannel' => 'secret' }, RejoinOnKick => 1, Rejoin_delay => 1, Retry_when_banned => 1, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_chan_mode irc_kick )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $heap->{port} = $port; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); if ($irc == $bot1) { $irc->yield(join => '#testchannel'); $irc->yield(join => '#testchannel2'); } } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); like($where, qr/#testchannel2?/, "$nick joined $where"); if ($nick eq 'TestBot1') { if ($where eq '#testchannel') { $bot1->yield(mode => $where, '+k secret'); } else { $bot1->yield(mode => $where, '+k secret2'); } } elsif ($where eq '#testchannel') { $heap->{bot2_joined}++; if ($heap->{bot2_joined} == 1) { $bot1->yield(mode => $where, '+k topsecret'); } else { $bot2->yield(join => '#testchannel2', 'secret2'); } } else { $heap->{bot2_joined_2}++; if ($heap->{bot2_joined_2} == 1) { $bot1->yield(kick => $where, 'TestBot2'); } else { $bot1->yield('quit'); $bot2->yield('quit'); } } } sub irc_chan_mode { my ($heap, $where, $mode) = @_[HEAP, ARG1, ARG2]; return if $bot1 != $_[SENDER]->get_heap(); if ($mode eq '+k') { pass("$where key set"); $heap->{key_set}++; if ($heap->{key_set} == 2) { $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $heap->{port}, }); } elsif ($heap->{key_set} == 3) { $bot1->yield(mode => $where, '+b TestBot2!*@*'); $bot1->yield(kick => $where, 'TestBot2'); } } elsif ($mode eq '+b') { pass('Ban set'); } elsif ($mode eq '-b') { pass('Ban removed'); } } sub irc_kick { my ($sender, $where, $victim) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $victim ne $irc->nick_name(); pass("$victim kicked from $where"); $bot1->delay([mode => $where, '-b TestBot2!*@*'], 4); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/12_autojoin/04_kicked.t0000644000175000017500000000570112353530642026125 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 8; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new( Channels => [ '#testchannel' ], RejoinOnKick => 1, Rejoin_delay => 1, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_kick irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $heap->{port} = $port; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name(). ' logged in'); if ($irc == $bot1) { $irc->yield(join => '#testchannel'); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $_[HEAP]->{port}, }); } } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', "$nick joined $where"); if ($nick eq 'TestBot2') { $heap->{joined}++; if ($heap->{joined} == 1) { $bot1->yield(kick => $where, 'TestBot2'); } else { $bot1->yield('quit'); $bot2->yield('quit'); } } } sub irc_kick { my ($sender, $where, $victim) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $victim ne $irc->nick_name(); pass("$victim kicked from $where"); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/03_botaddressed/0000755000175000017500000000000012353530642025013 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/03_botaddressed/01_load.t0000644000175000017500000000217712353530642026426 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotAddressed; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::BotAddressed->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::BotAddressed'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::BotAddressed'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::BotAddressed'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/03_botaddressed/02_output.t0000644000175000017500000000652212353530642027046 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotAddressed; use POE::Component::Server::IRC; use Test::More tests => 10; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(BotAddressed => POE::Component::IRC::Plugin::BotAddressed->new()); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_disconnected irc_join irc_bot_addressed irc_bot_mentioned irc_bot_mentioned_action )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); $heap->{joined}++; pass($irc->nick_name() . ' joined channel'); return if $heap->{joined} != 2; $bot1->yield(privmsg => $where, $bot2->nick_name . ': y halo thar'); $bot1->yield(privmsg => $where, '@' . $bot2->nick_name . ': y halo thar'); $bot1->yield(privmsg => $where, 'y halo thar, ' . $bot2->nick_name()); $bot1->yield(ctcp => $where, 'ACTION greets ' . $bot2->nick_name()); } sub irc_bot_addressed { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; my $irc = $sender->get_heap(); is($msg, 'y halo thar', 'irc_bot_addressed'); } sub irc_bot_mentioned { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; my $irc = $sender->get_heap(); is($msg, 'y halo thar, ' . $irc->nick_name(), 'irc_bot_mentioned'); } sub irc_bot_mentioned_action { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; my $irc = $sender->get_heap(); is($msg, 'greets ' . $irc->nick_name(), 'irc_bot_mentioned_action'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/02_connector/0000755000175000017500000000000012354017166024343 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/02_connector/01_load.t0000644000175000017500000000216012353530642025744 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::Connector; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::Connector->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::Connector'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Connector'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Connector'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/02_connector/02_reconnect.t0000644000175000017500000000407712353530642027017 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::Connector; use POE::Component::Server::IRC; use Test::More tests => 4; my $bot = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot->plugin_add(Connector => POE::Component::IRC::Plugin::Connector->new( timeout => 2, reconnect => 2, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my ($kernel, $sender, $heap) = @_[KERNEL, SENDER, HEAP]; my $irc = $sender->get_heap(); if (!$heap->{killed}) { pass('Logged in'); $ircd->daemon_server_kill($irc->nick_name()); $heap->{killed}++; return; } pass('Re-logged in'); $irc->plugin_del('Connector'); $irc->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; if ($heap->{killed} < 2) { $heap->{killed}++; pass('Killed from the IRC server'); return; } pass('irc_disconnected'); $kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/15_nickservid/0000755000175000017500000000000012354017166024516 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/15_nickservid/01_load.t0000644000175000017500000000221112353530642026114 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::NickServID; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::NickServID->new( Password => 'test' ); isa_ok($plugin, 'POE::Component::IRC::Plugin::NickServID'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::NickServID'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::NickServID'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/10_followtail/0000755000175000017500000000000012354017166024524 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/10_followtail/01_load.t0000644000175000017500000000346212353530642026133 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use File::Temp qw(tempfile); use POE qw(Filter::Line); use POE::Component::IRC; use POE::Component::IRC::Plugin::FollowTail; use Test::More tests => 5; my ($temp_fh, $temp_file) = tempfile(UNLINK => 1); my $inode = (stat $temp_fh)[1]; $temp_fh->autoflush(1); print $temp_fh "moocow\n"; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del irc_tail_input) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::FollowTail->new( filename => $temp_file, filter => POE::Filter::Line->new(), ); isa_ok($plugin, 'POE::Component::IRC::Plugin::FollowTail'); if (!$bot->plugin_add('TestPlugin', $plugin) ) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::FollowTail'); print $temp_fh "Cows go moo, yes they do\n"; } sub irc_tail_input { my ($sender, $filename, $input) = @_[SENDER, ARG0, ARG1]; my $irc = $sender->get_heap(); SKIP: { skip "No inodes on Windows", 1 if $^O eq 'MSWin32'; is((stat $filename)[1], $inode, 'Filename is okay'); } is($input, 'Cows go moo, yes they do', 'Cows go moo!'); if (!$irc->plugin_del('TestPlugin')) { fail('plugin_del failed'); $irc->yield('shutdown'); } } sub irc_plugin_del { my ($sender, $name, $plugin) = @_[SENDER, ARG0, ARG1]; my $irc = $sender->get_heap(); return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::FollowTail'); $irc->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/06_plugman/0000755000175000017500000000000012354017166024020 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/06_plugman/01_load.t0000644000175000017500000000214612353530642025425 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::PlugMan; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::PlugMan->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::PlugMan'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::PlugMan'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::PlugMan'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/06_plugman/03_irc_interface.t0000644000175000017500000000554612353530642027314 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::PlugMan; use POE::Component::Server::IRC; use Test::More tests => 12; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot1->plugin_add(PlugMan => POE::Component::IRC::Plugin::PlugMan->new( botowner => 'TestBot2!*@*', )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_chan_sync irc_public irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_chan_sync { my ($heap, $where) = @_[HEAP, ARG0]; is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; if ($heap->{joined} == 2) { $bot2->yield(privmsg => $where, $bot1->nick_name() . ': plugin_add CTCP POE::Component::IRC::Plugin::CTCP'); $bot2->yield(privmsg => $where, $bot1->nick_name() . ': plugin_reload CTCP'); $bot2->yield(privmsg => $where, $bot1->nick_name() . ': plugin_del CTCP'); } } sub irc_public { my $irc = $_[SENDER]->get_heap(); if ($irc == $bot1) { pass('Got command'); } else { pass('Got response'); $_[HEAP]->{response}++; if ($_[HEAP]->{response} == 3) { $bot1->yield('quit'); $bot2->yield('quit'); } } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/06_plugman/02_add.t0000644000175000017500000000366012353530642025241 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::PlugMan; use Test::More tests => 8; { package MyPlugin; use POE::Component::IRC::Plugin qw( :ALL ); sub new { return bless { @_[1..$#_] }, $_[0]; } sub PCI_register { $_[1]->plugin_register($_[0], 'SERVER', qw(all)); return 1; } sub PCI_unregister { return 1; } sub _default { return PCI_EAT_NONE; } } my $bot = POE::Component::IRC::State->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw( _start irc_plugin_add irc_plugin_del )], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::PlugMan->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::PlugMan'); if (!$bot->plugin_add('TestPlugin', $plugin)) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($sender, $name, $plugin) = @_[SENDER, ARG0, ARG1]; my $irc = $sender->get_heap(); return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::PlugMan'); ok($plugin->load('Test1', 'POE::Component::IRC::Test::Plugin'), 'PlugMan_load'); ok($plugin->reload('Test1'), 'PlugMan_reload'); ok($plugin->unload('Test1'), 'PlugMan_unload'); ok($plugin->load('Test2', MyPlugin->new()), 'PlugMan2_load'); ok($plugin->unload('Test2'), 'PlugMan2_unload'); if (!$irc->plugin_del('TestPlugin')) { fail('plugin_del failed'); $irc->yield('shutdown' ); } } sub irc_plugin_del { my ($sender, $name, $plugin) = @_[SENDER, ARG0, ARG1]; my $irc = $sender->get_heap(); return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::PlugMan'); $irc->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/06_plugman/04_auth_sub.t0000644000175000017500000000761312353530642026327 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::PlugMan; use POE::Component::Server::IRC; use Test::More tests => 14; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot3 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot1->plugin_add(PlugMan => POE::Component::IRC::Plugin::PlugMan->new( auth_sub => sub { return 1 if $_[1] =~ /^TestBot2!\S+@\S+$/; return }, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_chan_sync irc_public irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); $bot3->yield(register => 'all'); $bot3->yield(connect => { nick => 'TestBot3', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_chan_sync { my ($heap, $where) = @_[HEAP, ARG0]; is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; if ($heap->{joined} == 3) { # these should succeed $bot2->yield(privmsg => $where, $bot1->nick_name() . ': plugin_add CTCP POE::Component::IRC::Plugin::CTCP'); $bot2->yield(privmsg => $where, $bot1->nick_name() . ': plugin_reload CTCP'); } } sub irc_public { my $irc = $_[SENDER]->get_heap(); my $nick = (split /!/, $_[ARG0])[0]; my $where = $_[ARG1]->[0]; my $what = $_[ARG2]; return if $irc == $bot3; if ($irc == $bot1) { pass($irc->nick_name() . ' got command'); $_[HEAP]->{commands}++; if ($_[HEAP]->{commands} == 2) { # should fail and not generate a response $bot3->yield(privmsg => $where, $bot1->nick_name() . ': plugin_reload CTCP'); } elsif ($_[HEAP]->{commands} == 3) { # this should be the last message on the channel $bot1->yield(privmsg => $where, 'LAST MESSAGE'); } } elsif ($nick eq $bot1->nick_name()) { if ($what eq 'LAST MESSAGE') { $bot1->yield('quit'); $bot2->yield('quit'); $bot3->yield('quit'); return; } pass($irc->nick_name() . ' got response'); $_[HEAP]->{responses}++; if ($_[HEAP]->{responses} > 2) { fail "Superfluous message: $what\n"; return; } } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 3; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); $bot3->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/14_logger/0000755000175000017500000000000012354017166023633 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/14_logger/02_public.t0000644000175000017500000001336512353530642025605 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use File::Temp qw(tempdir); use File::Spec::Functions qw(catfile); use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Logger; use POE::Component::Server::IRC; use Test::More; my $log_dir = tempdir(CLEANUP => 1); my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(Logger => POE::Component::IRC::Plugin::Logger->new( Path => $log_dir, Notices => 1, )); my $file = catfile($log_dir, '#testchannel.log'); my @correct = ( qr/^--> TestBot2 \(\S+@\S+\) joins #testchannel$/, ' Oh hi', '>TestBot1< Hello', '--- TestBot1 disables topic protection', '--- TestBot1 enables secret channel status', '--- TestBot1 enables channel moderation', '--- TestBot1 sets channel keyword to foo', '--- TestBot1 removes channel keyword', '--- TestBot1 sets channel user limit to 10', '--- TestBot1 removes channel user limit', '--- TestBot1 sets ban on TestBot2!*@*', '--- TestBot1 removes ban on TestBot2!*@*', '--- TestBot1 gives channel operator status to TestBot2', '--- TestBot1 changes the topic to: Testing, 1 2 3', '--- TestBot1 is now known as NewNick', qr/^<-- NewNick \(\S+@\S+\) leaves #testchannel \(NewNick\)$/, qr/^--> NewNick \(\S+@\S+\) joins #testchannel$/, '<-- TestBot2 kicks NewNick from #testchannel (Bye bye)', qr/^--> NewNick \(\S+@\S+\) joins #testchannel$/, qr/^<-- NewNick \(\S+@\S+\) quits \(.*\)$/, ); plan tests => 10 + @correct; POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_part irc_kick irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my ($heap, $server) = @_[HEAP, ARG0]; my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); $heap->{logged_in}++; if ($heap->{logged_in} == 2) { $bot1->yield(join => '#testchannel'); } } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass("$nick joined channel"); $heap->{joined}++; if ($heap->{joined} == 1) { $bot2->yield(join => $where); return; } if ($heap->{done}) { $bot1->yield('quit'); return; } if ($irc == $bot2) { $bot1->yield(privmsg => $where, 'Oh hi'); $bot1->yield(notice => $where, 'Hello'); $bot1->yield(mode => $where, '-t'); $bot1->yield(mode => $where, '+s'); $bot1->yield(mode => $where, '+m'); $bot1->yield(mode => $where, '+k foo'); $bot1->yield(mode => $where, '-k'); $bot1->yield(mode => $where, '+l 10'); $bot1->yield(mode => $where, '-l'); $bot1->yield(mode => $where, '+b TestBot2!*@*'); $bot1->yield(mode => $where, '-b TestBot2!*@*'); $bot1->yield(mode => $where, '+o TestBot2'); $bot1->yield(topic => $where, 'Testing, 1 2 3'); $bot1->yield(nick => 'NewNick'); $bot1->yield(part => $where); } else { $bot2->yield(kick => $where, $bot1->nick_name(), 'Bye bye'); } } sub irc_part { my $irc = $_[SENDER]->get_heap(); my $nick = (split /!/, $_[ARG0])[0]; if ($nick eq $irc->nick_name()) { pass("$nick parted channel"); $irc->yield(join => $_[ARG1]); } } sub irc_kick { my ($heap, $chan, $nick) = @_[HEAP, ARG1, ARG2]; my $irc = $_[SENDER]->get_heap(); return if $nick ne $irc->nick_name(); pass($nick . ' kicked'); $irc->yield(join => $chan); $heap->{done} = 1; } sub irc_disconnected { my ($kernel, $sender) = @_[KERNEL, SENDER]; my $irc = $sender->get_heap(); pass('irc_disconnected'); if ($irc == $bot1) { $bot2->yield('quit'); } else { verify_log(); $kernel->yield('_shutdown'); } } sub verify_log { open my $log, '<', $file or die "Can't open log file '$file': $!"; my @lines = <$log>; close $log; my $check = 0; for my $line (@lines) { next if $line =~ /^\*{3}/; chomp $line; $line = substr($line, 20); last if !defined $correct[$check]; if (ref $correct[$check] eq 'Regexp') { like($line, $correct[$check], 'Line ' . ($check+1)); } else { is($line, $correct[$check], 'Line ' . ($check+1)); } $check++; } fail('Log too short') if $check > @correct; } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/14_logger/01_load.t0000644000175000017500000000230312353530642025233 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use File::Temp qw(tempdir); use Test::More tests => 3; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Logger; my $log_dir = tempdir(CLEANUP => 1); my $bot = POE::Component::IRC::State->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::Logger->new( Path => $log_dir ); isa_ok($plugin, 'POE::Component::IRC::Plugin::Logger'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Logger'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Logger'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/14_logger/05_log_sub.t0000644000175000017500000000561012353530642025756 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use File::Spec::Functions qw(catfile); use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Logger; use POE::Component::Server::IRC; use Test::More tests => 12; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); my $got = 0; $bot1->plugin_add(Logger => POE::Component::IRC::Plugin::Logger->new( Log_sub => sub { $got++; if ($got == 1) { is($_[0], '#testchannel', 'Got context'); is($_[1], 'join', 'Got type'); is($_[2], 'TestBot1', 'Got arguments'); } elsif ($got == 2) { is($_[0], '#testchannel', 'Got context'); is($_[1], '+n', 'Got type'); is($_[2], 'poco.server.irc', 'Got arguments'); } elsif ($got == 3) { is($_[0], '#testchannel', 'Got context'); is($_[1], '+t', 'Got type'); is($_[2], 'poco.server.irc', 'Got arguments'); } elsif ($got == 4) { is($_[0], '#testchannel', 'Got context'); is($_[1], 'quit', 'Got type'); is($_[2], 'TestBot1', 'Got arguments'); } } )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); } sub irc_001 { my ($heap, $server) = @_[HEAP, ARG0]; my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass("$nick joined channel"); $bot1->yield('quit'); } sub irc_disconnected { my ($kernel, $sender) = @_[KERNEL, SENDER]; my $irc = $sender->get_heap(); pass('irc_disconnected'); $kernel->yield('_shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/14_logger/03_private.t0000644000175000017500000001031312353530642025770 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use File::Temp qw(tempdir); use File::Spec::Functions qw(catfile); use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Logger; use POE::Component::Server::IRC; use Test::More; my $log_dir = tempdir(CLEANUP => 1); my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(Logger => POE::Component::IRC::Plugin::Logger->new( Path => $log_dir, Notices => 1, )); my $file = catfile($log_dir, 'testbot1.log'); unlink $file if -e $file; my @correct = ( ' Hello there', ' Hi yourself', '* TestBot1 is talking', '* TestBot2 is too', '>TestBot1< This is a notice', '>TestBot2< So is this', ); plan tests => 8 + @correct; POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_msg irc_ctcp_action irc_notice irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my ($heap, $server) = @_[HEAP, ARG0]; my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); $heap->{logged_in}++; return if $heap->{logged_in} != 2; $bot1->yield(privmsg => $bot2->nick_name(), 'Hello there'); $heap->{msg}++; } sub irc_msg { my $heap = $_[HEAP]; pass('irc_msg'); if ($heap->{msg} == 1) { $bot2->yield(privmsg => $bot1->nick_name(), 'Hi yourself'); $heap->{msg}++; } elsif ($heap->{msg} == 2) { $bot1->yield(ctcp => $bot2->nick_name(), 'ACTION is talking'); $heap->{msg}++; } } sub irc_ctcp_action { my $heap = $_[HEAP]; pass('irc_ctcp_action'); if ($heap->{msg} == 3) { $bot2->yield(ctcp => $bot1->nick_name(), 'ACTION is too'); $heap->{msg}++; } elsif ($heap->{msg} == 4) { $bot1->yield(notice => $bot2->nick_name(), 'This is a notice'); $heap->{msg}++; } } sub irc_notice { my $heap = $_[HEAP]; if ($heap->{msg} == 5) { $bot2->yield(notice => $bot1->nick_name(), 'So is this'); $heap->{msg}++; } elsif ($heap->{msg} == 6) { $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; if ($heap->{count} == 2) { verify_log(); $kernel->yield('_shutdown'); } } sub verify_log { open my $log, '<', $file or die "Can't open log file '$file': $!"; my @lines = <$log>; close $log; my $check = 0; for my $line (@lines) { next if $line =~ /^\*{3}/; chomp $line; $line = substr($line, 20); last if !defined $correct[$check]; if (ref $correct[$check] eq 'Regexp') { like($line, $correct[$check], 'Line ' . ($check+1)); } else { is($line, $correct[$check], 'Line ' . ($check+1)); } $check++; } fail('Log too short') if $check > @correct; } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/14_logger/04_dcc_chat.t0000644000175000017500000001051212353530642026050 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use File::Temp qw(tempdir); use File::Spec::Functions qw(catfile); use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Logger; use POE::Component::Server::IRC; use Test::More; my $log_dir = tempdir(CLEANUP => 1); my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(Logger => POE::Component::IRC::Plugin::Logger->new( Path => $log_dir, )); my $file = catfile($log_dir, '=testbot1.log'); unlink $file if -e $file; my @correct = ( qr/^--> Opened DCC chat connection with TestBot1 \(\S+:\d+\)$/, ' Oh hi', '* TestBot1 does something', ' Hi yourself', '* TestBot2 does something as well', qr/^<-- Closed DCC chat connection with TestBot1 \(\S+:\d+\)$/, ); plan tests => 7 + @correct; POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_dcc_request irc_dcc_start irc_dcc_chat irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my ($heap, $server) = @_[HEAP, ARG0]; my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); $heap->{logged_in}++; return if $heap->{logged_in} != 2; $bot2->yield(dcc => $bot1->nick_name() => CHAT => undef, undef, 5); } sub irc_dcc_request { my ($sender, $cookie) = @_[SENDER, ARG3]; my $irc = $sender->get_heap(); pass($irc->nick_name() . ' got dcc request'); $irc->yield(dcc_accept => $cookie); } sub irc_dcc_start { my ($sender, $heap, $id) = @_[SENDER, HEAP, ARG0]; my $irc = $sender->get_heap(); pass($irc->nick_name() . ' got irc_dcc_started'); $heap->{started}++; if ($heap->{started} == 2) { $irc->yield(dcc_chat => $id, 'Oh hi'); $irc->yield(dcc_chat => $id, "\001ACTION does something\001"); } } sub irc_dcc_chat { my ($heap, $sender, $id, $msg) = @_[HEAP, SENDER, ARG0, ARG3]; my $irc = $sender->get_heap(); $heap->{msgs}++; if ($heap->{msgs} == 2) { $irc->yield(dcc_chat => $id, 'Hi yourself'); $irc->yield(dcc_chat => $id, "\001ACTION does something as well\001"); } elsif ($heap->{msgs} == 4) { $irc->yield(dcc_close => $id); $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; if ($heap->{count} == 2) { verify_log(); $kernel->yield('_shutdown'); } } sub verify_log { open my $log, '<', $file or die "Can't open log file '$file': $!"; my @lines = <$log>; close $log; my $check = 0; for my $line (@lines) { next if $line =~ /^\*{3}/; chomp $line; $line = substr($line, 20); last if !defined $correct[$check]; if (ref $correct[$check] eq 'Regexp') { like($line, $correct[$check], 'Line ' . ($check+1)); } else { is($line, $correct[$check], 'Line ' . ($check+1)); } $check++; } fail('Log too short') if $check > @correct; } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/04_bottraffic/0000755000175000017500000000000012354017166024476 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/04_bottraffic/01_load.t0000644000175000017500000000216512353530642026104 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotTraffic; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::BotTraffic->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::BotTraffic'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::BotTraffic'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::BotTraffic'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/04_bottraffic/02_output.t0000644000175000017500000000547012353530642026530 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotTraffic; use POE::Component::Server::IRC; use Test::More tests => 7; my $bot = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot->plugin_add(BotTraffic => POE::Component::IRC::Plugin::BotTraffic->new()); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_bot_public irc_bot_msg irc_bot_action irc_bot_notice )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); pass('Joined channel'); $irc->yield(privmsg => $where, 'A public message'); } sub irc_bot_public { my ($sender, $text) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); is($text, 'A public message', 'irc_bot_public'); $irc->yield(privmsg => $irc->nick_name(), 'A private message'); } sub irc_bot_msg { my ($sender, $text) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); is($text, 'A private message', 'irc_bot_msg'); $irc->yield(ctcp => 'TestBot1', 'ACTION some action'); } sub irc_bot_action { my ($sender, $text) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); is($text, 'some action', 'irc_bot_action'); $irc->yield(notice => 'TestBot1', 'some notice'); } sub irc_bot_notice { my ($sender, $text) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); is($text, 'some notice', 'irc_bot_action'); $irc->yield('quit'); } sub irc_disconnected { my ($kernel) = $_[KERNEL]; pass('irc_disconnected'); $kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/17_dcc/0000755000175000017500000000000012354017166023110 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/17_dcc/07_nat.t0000644000175000017500000000562112353530642024367 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 9; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done irc_dcc_error )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, nataddr => '127.0.0.100', }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, nataddr => '127.0.0.100', }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where,'#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $bot1->yield(dcc => $bot2->nick_name() => CHAT => undef, undef, 3); } sub irc_dcc_request { my ($sender, $cookie) = @_[SENDER, ARG3]; pass('Got dcc request'); is($cookie->{addr}, '2130706532', 'NAT Address'); $sender->get_heap()->yield('quit'); } sub irc_dcc_done { pass('Got dcc timeout'); $_[SENDER]->get_heap()->yield('quit'); } sub irc_dcc_error { my ($sender, $error) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); fail('('. $irc->nick_name() .") DCC failed: $error"); $sender->get_heap()->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/17_dcc/06_chat.t0000644000175000017500000000622312353530642024522 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE::Component::IRC; use POE::Component::Server::IRC; use POE; use Test::More tests => 13; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done irc_dcc_chat irc_dcc_start irc_dcc_error )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $bot1->yield(dcc => $bot2->nick_name() => CHAT => undef, undef, 5); } sub irc_dcc_request { my ($sender, $cookie) = @_[SENDER, ARG3]; pass('Got dcc request'); $sender->get_heap()->yield(dcc_accept => $cookie); } sub irc_dcc_start { my ($sender, $id) = @_[SENDER, ARG0]; pass('DCC started'); $sender->get_heap()->yield(dcc_chat => $id => 'MOO'); } sub irc_dcc_chat { my ($sender, $id, $what) = @_[SENDER, ARG0, ARG3]; is($what, 'MOO', 'DCC CHAT test'); $sender->get_heap()->yield(dcc_close => $id); } sub irc_dcc_done { pass('Got dcc close'); $_[SENDER]->get_heap()->yield('quit'); } sub irc_dcc_error { my ($sender, $error) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); fail('('. $irc->nick_name() .") DCC failed: $error"); $sender->get_heap()->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/17_dcc/01_load.t0000644000175000017500000000212212353530642024507 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::DCC; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::DCC->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::DCC'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::DCC'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::DCC'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/17_dcc/02_timeout.t0000644000175000017500000000626712353530642025275 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE qw(Wheel::SocketFactory); use POE::Component::IRC; use POE::Component::Server::IRC; use Socket qw(unpack_sockaddr_in); use Test::More tests => 9; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done )], ], ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; my ($port, $addr) = get_port() or $kernel->yield(_shutdown => 'No free port'); $heap->{_addr} = unpack 'N', $addr; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub get_port { my $wheel = POE::Wheel::SocketFactory->new( BindAddress => '127.0.0.1', BindPort => 0, SuccessEvent => '_fake_success', FailureEvent => '_fake_failure', ); return if !$wheel; return unpack_sockaddr_in($wheel->getsockname()) if wantarray; return (unpack_sockaddr_in($wheel->getsockname))[0]; } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $bot1->yield(dcc => $bot2->nick_name() => CHAT => undef, undef, 3); } sub irc_dcc_request { my ($sender, $heap, $cookie) = @_[SENDER, HEAP, ARG3]; pass('Got dcc request'); is($cookie->{addr}, $heap->{_addr}, 'Correct Address Test'); $sender->get_heap()->yield('quit'); } sub irc_dcc_done { pass('Got dcc timeout'); $_[SENDER]->get_heap()->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/17_dcc/05_resume.t0000644000175000017500000000722012353530642025100 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use File::Temp qw(tempfile); use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::Differences; use Test::More tests => 12; my ($resume_fh, $resume_file) = tempfile(UNLINK => 1); my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done irc_dcc_start irc_dcc_error )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $bot1->yield(dcc => $bot2->nick_name() => SEND => 'Changes', undef, 5); } sub irc_dcc_request { my ($sender, $type, $cookie) = @_[SENDER, ARG1, ARG3]; return if $type ne 'SEND'; pass('Got dcc request'); open (my $orig, '<', 'Changes') or die "Can't open Changes file: $!"; sysread $orig, my $partial, 12000; truncate $resume_fh, 12000; syswrite $resume_fh, $partial; $sender->get_heap()->yield(dcc_resume => $cookie => $resume_file); } sub irc_dcc_start { pass('DCC started'); } sub irc_dcc_done { my ($sender, $size1, $size2) = @_[SENDER, ARG5, ARG6]; my $irc = $sender->get_heap(); return if $irc != $bot2; pass('Got dcc done'); is($size1, $size2, 'Send test results'); open my $orig, '<', 'Changes' or die $!; open my $resume, '<', $resume_file or die $!; my $orig_changes = do { local $/; <$orig> }; my $resume_changes = do { local $/; <$resume> }; eq_or_diff($resume_changes, $orig_changes, 'File contents match'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_dcc_error { my ($sender, $error) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); fail('('. $irc->nick_name() .") DCC failed: $error"); $sender->get_heap()->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/17_dcc/04_send_spaces.t0000644000175000017500000000632312353530642026071 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 13; use Data::Dumper; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); my $space_file = 'dcc with spaces'; open my $handle, '>', $space_file, or die "Couldn't open '$space_file': $!"; syswrite $handle, "One\nTwo\nThree\n"; POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done irc_dcc_start irc_dcc_error )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $bot1->yield(dcc => $bot2->nick_name() => SEND => $space_file => 1024 => 5); } sub irc_dcc_request { my ($sender, $cookie) = @_[SENDER, ARG3]; pass("Got dcc request"); $sender->get_heap()->yield(dcc_accept => $cookie => "$space_file.send"); } sub irc_dcc_start { pass('DCC started'); } sub irc_dcc_done { my ($sender, $size1, $size2) = @_[SENDER, ARG5, ARG6]; pass('Got dcc close'); is($size1, $size2, 'Send test results'); $sender->get_heap()->yield('quit'); } sub irc_dcc_error { my ($sender, $error) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); fail('('. $irc->nick_name() .") DCC failed: $error"); $irc->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; if ($heap->{count} == 2) { $kernel->yield('_shutdown'); unlink $space_file, "$space_file.send"; } } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/17_dcc/03_send.t0000644000175000017500000000606712353530642024537 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use File::Temp qw(tempfile); use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 13; my ($rcv_fh, $rcv_file) = tempfile(UNLINK => 1); my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done irc_dcc_start irc_dcc_error )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $bot1->yield(dcc => $bot2->nick_name() => SEND => 'Changes' => 1024 => 5); } sub irc_dcc_request { my ($sender, $cookie) = @_[SENDER, ARG3]; pass("Got dcc request"); $sender->get_heap()->yield(dcc_accept => $cookie => $rcv_file); } sub irc_dcc_start { pass('DCC started'); } sub irc_dcc_done { my ($sender, $size1, $size2) = @_[SENDER, ARG5, ARG6]; pass('Got dcc close'); is($size1, $size2, 'Send test results'); $sender->get_heap()->yield('quit'); } sub irc_dcc_error { my ($sender, $error) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); fail('('. $irc->nick_name() .") DCC failed: $error"); $sender->get_heap()->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/16_whois/0000755000175000017500000000000012354017166023507 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/16_whois/01_load.t0000644000175000017500000000213412353530642025111 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::Whois; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::Whois->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::Whois'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Whois'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Whois'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/16_whois/02_whois.t0000644000175000017500000000371712353530642025334 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 12; my $bot = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_whois irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(whois => $irc->nick_name()); } sub irc_whois { my ($sender, $heap, $whois) = @_[SENDER, HEAP, ARG0]; my $irc = $sender->get_heap(); pass('irc_whois'); is(keys %$whois, 8, 'Got whois info'); for my $key (qw(actually nick idle host user server real signon)) { ok(defined $whois->{$key}, "$key key present"); } $irc->yield('quit'); } sub irc_disconnected { my ($kernel, $heap, $sender) = @_[KERNEL, HEAP, SENDER]; my $irc = $sender->get_heap(); pass('irc_disconnected'); $kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/08_proxy/0000755000175000017500000000000012354017166023540 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/08_proxy/01_load.t0000644000175000017500000000215212353530642025142 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Proxy; my $bot = POE::Component::IRC::State->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::Proxy->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::Proxy'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Proxy'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Proxy'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/04_plugins/08_proxy/02_connect.t0000644000175000017500000000652512353530642025665 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Proxy; use POE::Component::Server::IRC; use Socket qw(unpack_sockaddr_in); use Test::More tests => 8; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure irc_proxy_up _shutdown irc_001 irc_332 irc_topic irc_join irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; $bot1->plugin_add(Proxy => POE::Component::IRC::Plugin::Proxy->new( password => 'proxy_pass', )); $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub irc_proxy_up { my ($heap, $port) = @_[HEAP, ARG0]; $heap->{proxy_port} = (unpack_sockaddr_in($port))[0]; } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); if ($irc == $bot1) { pass($irc->nick_name() . ' logged in'); $irc->yield(join => '#testchannel'); } else { pass($irc->nick_name() . ' logged in (via proxy)'); } } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); if ($irc == $bot1) { like($where, qr/#testchannel/, "$nick joined $where"); $irc->yield(topic => $where, 'Some topic'); } else { like($where, qr/#testchannel/, "$nick joined $where (via proxy)"); } } sub irc_topic { my ($heap, $sender, $topic) = @_[HEAP, SENDER, ARG2]; my $irc = $sender->get_heap(); is($topic, 'Some topic', $irc->nick_name() . ' changed topic'); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $heap->{proxy_port}, password => 'proxy_pass', }); } sub irc_332 { my ($heap, $sender, $reply) = @_[HEAP, SENDER, ARG2]; my $topic = $reply->[1]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($topic, 'Some topic', $irc->nick_name() . ' got topic (via proxy)'); $bot2->yield('quit'); $bot1->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/0000755000175000017500000000000012354017166022164 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/17_raw.t0000644000175000017500000000347612353530642023461 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 6; my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); my $bot = POE::Component::IRC->spawn( Flood => 1, Raw => 1, ); isa_ok($ircd, 'POE::Component::Server::IRC'); isa_ok($bot, 'POE::Component::IRC'); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_connected irc_raw_out irc_001 irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $bot->yield(register => 'all'); $bot->yield( connect => { nick => 'TestBot', server => '127.0.0.1', port => $port, }); } sub irc_connected { pass('Connected'); } sub irc_raw_out { my ($raw) = $_[ARG0]; pass('Got raw nick string') if $raw =~ /^NICK /; } sub irc_001 { my ($sender) = $_[SENDER]; my $irc = $sender->get_heap(); ok($irc->logged_in(), 'Logged in'); $irc->yield('quit'); } sub irc_disconnected { pass('Got irc_disconnected'); $poe_kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/06_online.t0000644000175000017500000000725112353530642024145 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use POE qw(Wheel::SocketFactory); use POE::Component::IRC; use Socket qw(AF_INET inet_ntoa SOCK_STREAM unpack_sockaddr_in); use Test::More tests => 5; my $bot = POE::Component::IRC->spawn(); my $server = 'irc.freenode.net'; my $nick = "PoCoIRC" . $$; POE::Session->create( package_states => [ main => [qw( _start _shutdown _success _failure _irc_connect _time_out _default irc_registered irc_connected irc_001 irc_465 irc_error irc_socketerr irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Connect manually first to see if our internets are working. # If not, we can pass the error info to Test::More's skip() $heap->{sockfactory} = POE::Wheel::SocketFactory->new( SocketDomain => AF_INET, SocketType => SOCK_STREAM, SocketProtocol => 'tcp', RemoteAddress => $server, RemotePort => 6667, SuccessEvent => '_success', FailureEvent => '_failure', ); $kernel->delay(_time_out => 40); $heap->{numeric} = 0; $heap->{tests} = 5; } sub _success { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{address} = inet_ntoa($_[ARG1]); $kernel->delay('_time_out'); delete $heap->{sockfactory}; $kernel->yield('_irc_connect'); } sub _failure { my ($kernel, $heap, $operation, $errnum, $errstr) = @_[KERNEL, HEAP, ARG0..ARG2]; delete $heap->{sockfactory}; $kernel->yield(_shutdown => "$operation $errnum $errstr"); } sub _time_out { delete $_[HEAP]->{sockfactory}; $poe_kernel->yield(_shutdown => 'Connection timed out'); } sub _shutdown { my ($heap, $skip) = @_[HEAP, ARG0]; if ( !$skip && !$heap->{numeric} ) { $skip = 'Never received a numeric IRC event'; } SKIP: { skip $skip, $heap->{tests} if $skip; } $poe_kernel->alarm_remove_all(); $bot->yield('shutdown'); } sub _irc_connect { my ($heap) = $_[HEAP]; $bot->yield(register => 'all'); $bot->yield(connect => { server => $heap->{address}, nick => $nick, }); } sub irc_registered { my ($heap, $irc) = @_[HEAP, ARG0]; isa_ok($irc, 'POE::Component::IRC'); $heap->{tests}--; } sub irc_connected { TODO: { local $TODO = "K-lines or other unforeseen issues could derail this test"; pass('Connected'); }; $_[HEAP]->{tests}--; } sub irc_socketerr { my ($kernel) = $_[KERNEL]; $kernel->yield(_shutdown => $_[ARG0] ); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); TODO: { local $TODO = "K-lines or other unforeseen issues could derail this test"; pass('Logged in'); }; $_[HEAP]->{numeric}++; $_[HEAP]->{tests}--; $irc->yield('quit'); } sub irc_465 { my $irc = $_[SENDER]->get_heap(); TODO: { local $TODO = "Hey we is K-lined"; pass('ERR_YOUREBANNEDCREEP'); }; $_[HEAP]->{numeric}++; $_[HEAP]->{tests}--; } sub irc_error { TODO: { local $TODO = "K-lines or other unforeseen issues could derail this test"; pass('irc_error'); }; $_[HEAP]->{tests}--; } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; TODO: { local $TODO = "K-lines or other unforeseen issues could derail this test"; pass('Disconnected'); }; $heap->{tests}--; $kernel->yield('_shutdown'); } sub _default { my ($event, $args) = @_[ARG0 .. $#_]; return unless $event =~ m!^irc_\d+!; $_[HEAP]->{numeric}++; return; } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/07_subclass.t0000644000175000017500000000561112353530642024477 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 17; { package SubclassIRC; use base qw(POE::Component::IRC); use Test::More; my $VERSION = 1; sub S_001 { my $irc1 = shift; $irc1->SUPER::S_001(@_); my $irc2 = shift; pass('PoCo-IRC as subclass'); isa_ok($irc1, 'POE::Component::IRC'); isa_ok($irc2, 'POE::Component::IRC'); is($irc1->server_name(), 'poco.server.irc', 'Server Name Test'); is($irc2->nick_name(), 'TestBot', 'Nick Name Test'); } } my $bot = SubclassIRC->spawn(Flood => 1); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); isa_ok($bot, 'POE::Component::IRC'); isa_ok($ircd, 'POE::Component::Server::IRC'); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_registered irc_connected irc_001 irc_whois irc_join irc_error irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield( connect => { nick => 'TestBot', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $bot->yield('shutdown'); $ircd->yield('shutdown'); } sub irc_registered { my ($irc) = $_[ARG0]; isa_ok($irc, 'POE::Component::IRC'); } sub irc_connected { pass('Connected'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('connect'); is($irc->server_name(), 'poco.server.irc', 'Server Name Test'); is($irc->nick_name(), 'TestBot', 'Nick Name Test'); $irc->yield(whois => 'TestBot'); } sub irc_whois { my ($sender, $whois) = @_[SENDER, ARG0]; is($whois->{nick}, 'TestBot', 'Whois hash test'); $sender->get_heap()->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); is($nick, $irc->nick_name(), 'JOINER Test'); is($where, '#testchannel', 'Joined Channel Test'); $irc->yield('quit'); } sub irc_error { pass('irc_error'); } sub irc_disconnected { my ($kernel) = $_[KERNEL]; pass('irc_disconnected'); $kernel->yield('_shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/10_signal.t0000644000175000017500000000375212353530642024133 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 7; my $bot = POE::Component::IRC->spawn(Flood => 1); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_registered irc_connected irc_001 irc_error irc_disconnected irc_shutdown )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $session, $port) = @_[KERNEL, HEAP, SESSION, ARG0]; $kernel->signal($kernel, 'POCOIRC_REGISTER', $session, 'all'); $heap->{port} = $port; } sub irc_registered { my ($heap, $irc) = @_[HEAP, ARG0]; pass('Registered'); isa_ok($irc, 'POE::Component::IRC'); $irc->yield(connect => { nick => 'TestBot', server => '127.0.0.1', port => $heap->{port}, }); } sub irc_connected { pass('Connected'); } sub irc_001 { my ($kernel, $sender, $text) = @_[KERNEL, SENDER, ARG1]; my $irc = $sender->get_heap(); pass('Logged in'); $irc->yield('quit'); } sub irc_error { pass('irc_error'); } sub irc_disconnected { pass('irc_disconnected'); $poe_kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $kernel->signal($kernel, 'POCOIRC_SHUTDOWN'); } sub irc_shutdown { pass('irc_shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/04_ipv6.t0000644000175000017500000001013612353530642023537 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use POE qw(Wheel::SocketFactory Wheel::ReadWrite Filter::Line); use POE::Component::IRC; use Test::More; my $tests = 4; BEGIN { my $GOT_SOCKET6; eval { Socket->import(qw(AF_INET6 unpack_sockaddr_in6 inet_pton)); $GOT_SOCKET6 = 1; }; if (!$GOT_SOCKET6) { eval { require Socket6; Socket6->import(qw(AF_INET6 unpack_sockaddr_in6 inet_pton)); $GOT_SOCKET6 = 1; }; plan skip_all => 'Socket6 is needed for IPv6 tests' if !$GOT_SOCKET6; } } # Argh, we need to be "smart" and see if we need GAI or not... # Perl-5.14.0 will core getaddrinfo() in it's Socket.pm eval { Socket->import('getaddrinfo') }; if ($@) { eval { require Socket::GetAddrInfo; Socket::GetAddrInfo->import(qw(:newapi getaddrinfo)) }; if ($@) { plan skip_all => 'Socket::GetAddrInfo is needed for IPv6 tests'; } } my $addr = eval { inet_pton(AF_INET6, "::1"); }; if (!defined $addr) { plan skip_all => "IPv6 tests require a configured localhost address ('::1')"; } plan tests => $tests; my $bot = POE::Component::IRC->spawn(); POE::Session->create( package_states => [ main => [qw( _start accept_client factory_failed client_input client_error irc_connected irc_socketerr irc_001 )] ] ); $poe_kernel->run(); sub _start { my ($heap) = $_[HEAP]; $heap->{sockfactory} = POE::Wheel::SocketFactory->new( SocketDomain => AF_INET6, BindAddress => '::1', BindPort => 0, SuccessEvent => 'accept_client', FailureEvent => 'factory_failed', ); my $packed_socket = $heap->{sockfactory}->getsockname; if (!$packed_socket) { diag("ERROR: Couldn't get the packed socket"); return; } eval { ($heap->{bindport}) = unpack_sockaddr_in6($packed_socket) }; if ($@) { diag("ERROR: $@"); return; } if ($heap->{bindport} == 0) { delete $heap->{sockfactory}; _skip_rest('$heap->{bindport} == 0'); return; } $bot->yield(register => 'all'); $bot->yield(connect => { Nick => 'testbot', Server => '::1', useipv6 => 1, Port => $heap->{bindport}, Username => 'testbot', Ircname => 'testbot 1.1', }); } sub accept_client { my ($heap, $socket) = @_[HEAP, ARG0]; my $wheel = POE::Wheel::ReadWrite->new( Handle => $socket, InputEvent => 'client_input', ErrorEvent => 'client_error', Filter => POE::Filter::Line->new( Literal => "\x0D\x0A" ), ); $heap->{client} = $wheel; } sub factory_failed { my ($heap, $syscall, $errno, $error) = @_[HEAP, ARG0..ARG2]; delete $_[HEAP]->{sockfactory}; _skip_rest("syscall error $errno: $error") if $tests; } sub client_input { my ($heap, $input) = @_[HEAP, ARG0]; SWITCH: { if ($input =~ /^NICK /) { pass('Server got NICK'); $tests--; $heap->{got_nick} = 1; last SWITCH; } if ($input =~ /^USER /) { pass('Server got USER'); $tests--; $heap->{got_user} = 1; last SWITCH; } if ($input =~ /^QUIT/ ) { delete $heap->{client}; delete $heap->{sockfactory}; return; } } if ($heap->{got_nick} && $heap->{got_user}) { # Send back irc_001 $heap->{client}->put(':test.script 001 testbot :Welcome to poconet Internet Relay Chat Network testbot!testbot@127.0.0.1'); } } sub client_error { my ($heap) = $_[HEAP]; delete $heap->{client}; delete $heap->{sockfactory}; } sub irc_connected { pass('Connected'); $tests--; } sub irc_socketerr { _skip_rest($_[ARG0]) if $tests; } sub irc_001 { pass('Logged in'); $bot->yield('shutdown'); } sub _skip_rest { my ($error) = @_; SKIP: { skip "AF_INET6 probably not supported ($error)", $tests; } $tests = 0; $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/13_activity.t0000644000175000017500000001116412353530642024511 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE::Component::IRC; use POE::Component::Server::IRC; use POE; use Test::More tests => 16; my $bot1 = POE::Component::IRC->spawn(Flood => 1); my $bot2 = POE::Component::IRC->spawn(Flood => 1); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start _shutdown ircd_listener_add ircd_listener_failure irc_001 irc_join irc_invite irc_mode irc_public irc_notice irc_ctcp_action irc_nick irc_topic irc_kick irc_msg irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $_[HEAP]->{logged_in}++; if ($_[HEAP]->{logged_in} == 2) { $bot1->yield(join => '#testchannel'); } } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); if ($nick eq $irc->nick_name()) { is($where, '#testchannel', 'Joined Channel Test'); if ($irc == $bot1) { $bot1->yield(invite => $bot2->nick_name(), $where); } else { $bot1->yield(mode => $where, '+m'); } } } sub irc_invite { pass('irc_invite'); $_[SENDER]->get_heap()->yield(join => $_[ARG1]); } sub irc_mode { my ($sender, $where, $mode) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); my $chantypes = join('', @{ $irc->isupport('CHANTYPES') || ['#', '&']}); return if $where !~ /^[$chantypes]/; return if $irc != $bot1; if ($mode =~ /\+[nt]/) { pass('Got initial channel modes'); } else { is($mode, '+m', 'irc_mode'); $bot1->yield(privmsg => $where, 'Test message 1'); } } sub irc_public { my ($sender, $where, $msg) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($msg, 'Test message 1', 'irc_public'); $bot1->yield(notice => $where->[0], 'Test message 2'); } sub irc_notice { my ($sender, $where, $msg) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($msg, 'Test message 2', 'irc_notice'); $bot1->yield(ctcp => $where->[0], 'ACTION Test message 3'); } sub irc_ctcp_action { my ($sender, $where, $msg) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($msg, 'Test message 3', 'irc_ctcp_action'); $bot1->yield(topic => $where->[0], 'Test topic'); } sub irc_topic { my ($sender, $chan, $msg) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($msg, 'Test topic', 'irc_topic'); $bot1->yield(nick => 'NewNick'); } sub irc_nick { my $irc = $_[SENDER]->get_heap(); return if $irc != $bot2; pass('irc_nick'); $bot1->yield(kick => '#testchannel', $bot2->nick_name(), 'Good bye'); } sub irc_kick { my ($sender, $error) = @_[SENDER, ARG3]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($error, 'Good bye', 'irc_kick'); $bot1->yield(privmsg => $bot2->nick_name(), 'Test message 4'); } sub irc_msg { my ($sender, $msg) = @_[SENDER, ARG2]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($msg, 'Test message 4', 'irc_msg'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/15_no_stacked_ctcp.t0000644000175000017500000000521412353530642026001 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 6; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_ctcp_version irc_msg irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $heap = $_[HEAP]; my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $heap->{connected}++; return if $heap->{connected} != 2; $bot1->yield(privmsg => $bot2->nick_name(), "\001VERSION\001\001VERSION\001"); $bot1->yield(privmsg => $bot2->nick_name(), "goodbye"); $irc->yield(join => '#testchannel'); } sub irc_ctcp_version { my ($sender, $heap) = @_[SENDER, HEAP]; my $irc = $sender->get_heap(); $heap->{got_ctcp}++; if ($heap->{got_ctcp} == 1) { pass('Got first CTCP VERSION'); } elsif ($heap->{got_ctcp} == 2) { fail('Got second CTCP VERSION'); } } sub irc_msg { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; my $irc = $sender->get_heap(); is($msg, 'goodbye', 'Got private message'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/08_parent_session.t0000644000175000017500000000146012353530642025713 0ustar gregoagregoa# This tests the following from IRC.pm's pod: # # Starting with version 4.96, if you spawn the component from inside another # POE session, the component will automatically register that session as # wanting 'all' irc events. That session will receive an irc_registered # event indicating that the component is up and ready to go. use strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC; use Test::More tests => 2; POE::Session->create( package_states => [ main => [qw(_start irc_registered)], ], ); $poe_kernel->run(); sub _start { my ($heap) = $_[HEAP]; $heap->{irc} = POE::Component::IRC->spawn(); } sub irc_registered { my ($heap, $irc) = @_[HEAP, ARG0]; pass('Child registered us'); isa_ok($irc, 'POE::Component::IRC'); $irc->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/03_socketerr.t0000644000175000017500000000275712353530642024665 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use POE qw(Wheel::SocketFactory); use POE::Component::IRC; use Socket qw(unpack_sockaddr_in); use Test::More tests => 1; my $bot = POE::Component::IRC->spawn(); POE::Session->create( package_states => [ main => [qw( _start _try_connect _shutdown irc_socketerr )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; my $port = get_port() or $kernel->yield(_shutdown => 'No free port'); $kernel->yield(_try_connect => $port); $kernel->delay(_shutdown => 60, 'Timed out'); } sub get_port { my $wheel = POE::Wheel::SocketFactory->new( BindAddress => '127.0.0.1', BindPort => 0, SuccessEvent => '_fake_success', FailureEvent => '_fake_failure', ); return if !$wheel; return unpack_sockaddr_in($wheel->getsockname()) if wantarray; return (unpack_sockaddr_in($wheel->getsockname))[0]; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $bot->yield(unregister => 'socketerr'); $bot->yield('shutdown'); } sub _try_connect { my ($port) = $_[ARG0]; $bot->yield(register => 'socketerr'); $bot->yield( connect => { nick => 'TestBot', server => '127.0.0.1', port => $port, }); } sub irc_socketerr { my ($kernel) = $_[KERNEL]; pass('Socket Error'); $kernel->yield('_shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/01_public_methods.t0000644000175000017500000000071012353530642025646 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use POE::Component::IRC; use Test::More tests => 1; my @methods = qw( spawn new nick_name localaddr server port server_name session_id session_alias send_queue connected disconnect logged_in raw_events isupport isupport_dump_keys yield call delay delay_remove resolver send_event ); can_ok('POE::Component::IRC', @methods); libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/11_multi_signal.t0000644000175000017500000000431512353530642025342 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 14; my $bot1 = POE::Component::IRC->spawn(Flood => 1); my $bot2 = POE::Component::IRC->spawn(Flood => 1); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_registered irc_connected irc_001 irc_error irc_disconnected irc_shutdown )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $session, $port) = @_[KERNEL, HEAP, SESSION, ARG0]; $kernel->signal($kernel, 'POCOIRC_REGISTER', $session, 'all'); $heap->{nickcounter} = 0; $heap->{port} = $port; } sub irc_registered { my ($heap, $irc) = @_[HEAP, ARG0]; $heap->{nickcounter}++; pass('Registered ' . $heap->{nickcounter}); isa_ok($irc, 'POE::Component::IRC'); $irc->yield(connect => { nick => 'TestBot' . $heap->{nickcounter}, server => '127.0.0.1', port => $heap->{port}, }); } sub irc_connected { pass('Connected'); } sub irc_001 { my ($sender,$text) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); pass('Logged in'); $irc->yield('quit'); } sub irc_error { pass('irc_error'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $kernel->signal($kernel, 'POCOIRC_SHUTDOWN'); $ircd->yield('shutdown'); } sub irc_shutdown { pass('irc_shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/18_shutdown.t0000644000175000017500000000253412353530642024536 0ustar gregoagregoa#!/usr/bin/env perl use strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC; use Socket qw(unpack_sockaddr_in); use Test::More tests => 4; my $bot = POE::Component::IRC->spawn(Flood => 1); POE::Session->create( package_states => [ main => [qw( _start _shutdown irc_shutdown )], ], ); $poe_kernel->run(); sub _start { my ($kernel, $parent_heap) = @_[KERNEL, HEAP]; $bot->yield(register => 'all'); # we're testing if pocoirc correctly copes with a session immediately # dying after sending a 'shutdown' event POE::Session->create( inline_states => { _start => sub { $parent_heap->{sub_id} = $_[SESSION]->ID(); pass('Subsession started'); $bot->yield('shutdown'); }, _stop => sub { pass('Subsession stopped'); } }, ); $kernel->delay(_shutdown => 60, 'Timed out'); } sub irc_shutdown { my ($heap, $killer_id) = @_[HEAP, ARG0]; pass('IRC component shut down'); is($killer_id, $heap->{sub_id}, 'Killer session id matches'); $poe_kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/14_newline.t0000644000175000017500000000556512353530642024327 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 9; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_public irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $irc->yield(quote => "PRIVMSG $where :one\nPRIVMSG $where :two"); $irc->yield(privmsg => $where, "foo\nbar"); $irc->yield(privmsg => $where, "baz\rquux"); } sub irc_public { my ($sender, $heap, $where, $msg) = @_[SENDER, HEAP, ARG1, ARG2]; my $irc = $sender->get_heap(); my $chan = $where->[0]; $heap->{got_msg}++; if ($heap->{got_msg} == 1) { is($msg, 'one', 'First message'); } elsif ($heap->{got_msg} == 2) { is($msg, 'foo', 'Second message'); } elsif ($heap->{got_msg} == 3) { is($msg, 'baz', 'Third message'); $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/09_multiple.t0000644000175000017500000000561312353530642024517 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 20; my $bot1 = POE::Component::IRC->spawn(Flood => 1); my $bot2 = POE::Component::IRC->spawn(Flood => 1); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_registered irc_connected irc_001 irc_join irc_mode irc_public irc_error irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_registered { my ($irc) = $_[ARG0]; isa_ok($irc, 'POE::Component::IRC'); } sub irc_connected { pass('Connected'); } sub irc_001 { my ($kernel, $sender, $text) = @_[KERNEL, SENDER, ARG1]; my $irc = $sender->get_heap(); pass('Logged in'); is($irc->server_name(), 'poco.server.irc', 'Server Name Test'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); if ($nick eq $irc->nick_name()) { is($where, '#testchannel', 'Joined Channel Test'); } else { $irc->yield(mode => $where => '+o' => $nick); $irc->yield(privmsg => $where => 'HELLO'); $irc->yield('quit'); } } sub irc_mode { pass('Mode Test'); } sub irc_public { my ($sender, $who, $where, $what) = @_[SENDER, ARG0..ARG2]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); is($what, 'HELLO', 'irc_public test'); $irc->yield('quit'); } sub irc_error { pass('irc_error'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $bot1->yield('shutdown'); $bot2->yield('shutdown'); $ircd->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/05_resolver.t0000644000175000017500000000150512353530642024515 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC; use Test::More; BEGIN { my $GOT_DNS; eval { require POE::Component::Client::DNS; $GOT_DNS = 1 if $POE::Component::Client::DNS::VERSION >= 0.99; }; if (!$GOT_DNS) { plan skip_all => 'POE::Component::Client::DNS 0.99 not installed'; } } plan tests => 4; my $dns = POE::Component::Client::DNS->spawn(); my $bot = POE::Component::IRC->spawn( Resolver => $dns ); isa_ok($bot, 'POE::Component::IRC'); isa_ok($dns, 'POE::Component::Client::DNS'); POE::Session->create( package_states => [ main => ['_start'] ], ); $poe_kernel->run(); sub _start { isa_ok($bot->resolver(), 'POE::Component::Client::DNS'); is($bot->resolver(), $dns, 'DNS objects match'); $bot->yield('shutdown'); $dns->shutdown(); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/12_delays.t0000644000175000017500000000205012353530642024127 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC; use Socket qw(unpack_sockaddr_in); use Test::More tests => 4; my $bot = POE::Component::IRC->spawn(); POE::Session->create( package_states => [ main => [qw( _start irc_registered irc_delay_set irc_delay_removed )], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); } sub irc_registered { my ($heap, $irc) = @_[HEAP, ARG0]; $heap->{alarm_id} = $irc->delay( [ connect => { nick => 'TestBot', server => '127.0.0.1', port => 6667, } ], 25 ); ok($heap->{alarm_id}, 'Set alarm'); } sub irc_delay_set { my ($heap, $event, $alarm_id) = @_[HEAP, STATE, ARG0]; is($alarm_id, $heap->{alarm_id}, $_[STATE]); my $opts = $bot->delay_remove($alarm_id); ok($opts, 'Delay Removed'); } sub irc_delay_removed { my ($heap, $alarm_id) = @_[HEAP, ARG0]; is($alarm_id, $heap->{alarm_id}, $_[STATE] ); $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/16_nonclosing_ctcp.t0000644000175000017500000000462212353530642026043 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 5; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_ctcp_version irc_msg irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $heap = $_[HEAP]; my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $heap->{connected}++; return if $heap->{connected} != 2; $bot1->yield(privmsg => $bot2->nick_name(), "\001VERSION"); $bot1->yield(privmsg => $bot2->nick_name(), "goodbye"); $irc->yield(join => '#testchannel'); } sub irc_ctcp_version { fail('Got mangled CTCP VERSION'); } sub irc_msg { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; my $irc = $sender->get_heap(); is($msg, 'goodbye', 'Got private message'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/02_behavior/02_connect.t0000644000175000017500000000640412353530642024305 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 38; my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); my $bot = POE::Component::IRC->spawn(Flood => 1); isa_ok($ircd, 'POE::Component::Server::IRC'); isa_ok($bot, 'POE::Component::IRC'); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown _default irc_connected irc_001 irc_391 irc_whois irc_join irc_isupport irc_error irc_disconnected irc_shutdown )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $bot->yield(register => 'all'); $bot->yield( connect => { nick => 'TestBot', server => '127.0.0.1', port => $port, }); } sub irc_connected { pass('Connected'); } sub irc_001 { my ($sender) = $_[SENDER]; my $irc = $sender->get_heap(); ok($irc->logged_in(), 'Logged in'); is($irc->server_name(), 'poco.server.irc', 'Server Name Test'); is($irc->nick_name(), 'TestBot', 'Nick Name Test'); is($irc->session_alias(), $irc, 'Alias Test'); $irc->yield('time'); $irc->yield(whois => 'TestBot'); } sub irc_isupport { my $isupport = $_[ARG0]; isa_ok($isupport, 'POE::Component::IRC::Plugin::ISupport'); is($isupport->isupport('NETWORK'), 'poconet', 'ISupport Network'); is($isupport->isupport('CASEMAPPING'), 'rfc1459', 'ISupport Casemapping'); for my $isupp ( qw(MAXCHANNELS MAXBANS MAXTARGETS NICKLEN TOPICLEN KICKLEN CHANTYPES PREFIX CHANMODES) ) { ok($isupport->isupport($isupp), "Testing $isupp"); } } # RPL_TIME sub irc_391 { my ($time) = $_[ARG1]; pass('Got the time, baby'); } sub irc_whois { my ($sender, $whois) = @_[SENDER, ARG0]; is($whois->{nick}, 'TestBot', 'Whois hash test'); $sender->get_heap()->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); is($nick, $irc->nick_name(), 'JOINER Test'); is($where, '#testchannel', 'Joined Channel Test'); $irc->yield('quit'); } sub irc_error { pass('Got irc_error'); } sub irc_shutdown { pass('Got irc_shutdown'); } sub irc_disconnected { pass('Got irc_disconnected'); $poe_kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } sub _default { my ($event) = $_[ARG0]; return 0 if $event !~ /^irc_(002|003|004|422|251|255|311|312|317|318|353|366)$/; pass("Got $event"); return 0; } libpoe-component-irc-perl-6.88+dfsg.orig/t/03_subclasses/0000755000175000017500000000000012354017166022535 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/03_subclasses/06_state_nick_sync.t0000644000175000017500000000760512353530642026415 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 16; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, AwayPoll => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_366 irc_join irc_nick_sync irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name . ' logged in'); if ($irc == $bot1) { $irc->yield(join => '#testchannel'); $irc->yield(join => '#testchannel2'); } } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); if ($irc == $bot1 && $nick eq $bot2->nick_name() && !$heap->{seen_bot2}) { is($irc->nick_info($bot2->nick_name())->{Server}, undef, $bot1->nick_name(). " hasn't synced ".$bot2->nick_name(). " yet"); $heap->{seen_bot2} = 1; } return if $nick ne $irc->nick_name(); pass($irc->nick_name() . " joined channel $where"); if (keys %{ $bot1->channels } == 2 && !keys %{ $bot2->channels }) { $bot2->yield(join => "#testchannel"); } if ($irc == $bot2 && keys %{ $bot2->channels } == 1) { is($irc->nick_info($bot1->nick_name()), undef, $bot2->nick_name()." doesn't know about ".$bot1->nick_name." yet"); } } sub irc_366 { my ($sender, $heap, $args) = @_[SENDER, HEAP, ARG2]; my $irc = $sender->get_heap(); my $chan = $args->[0]; return if $irc != $bot2; return if $chan ne '#testchannel'; my @nicks = $irc->channel_list($chan); ok(defined $_, 'Nickname is defined') for @nicks; } sub irc_nick_sync { my ($sender, $heap, $nick, $chan) = @_[SENDER, HEAP, ARG0, ARG1]; my $irc = $sender->get_heap(); if ($irc == $bot1) { is($nick, $bot2->nick_name(), 'Nick from irc_nick_sync is correct'); $heap->{nick_sync}++; if ($heap->{nick_sync} == 1) { is($chan, '#testchannel', 'Channel from irc_nick_sync is correct'); $bot2->yield(join => "#testchannel2"); } if ($heap->{nick_sync} == 2) { is($chan, '#testchannel2', 'Channel from irc_nick_sync is correct'); $_->yield('quit') for ($bot1, $bot2); } } } sub irc_disconnected { my ($kernel, $heap, $info) = @_[KERNEL, HEAP, ARG1]; pass($info->{Nick} . ' disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/03_subclasses/04_netsplit.t0000644000175000017500000001637012353530642025074 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::Common qw(parse_user); use POE::Component::IRC::State; use POE::Component::Server::IRC; use Test::More tests => 43; my $bot = POE::Component::IRC::State->spawn(Flood => 1); my $ircd1 = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, Config => { servername => 'ircd1.poco.server.irc', }, ); my $ircd2 = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, Config => { servername => 'ircd2.poco.server.irc', }, ); my $pass = 'letmein'; isa_ok($bot, 'POE::Component::IRC::State'); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_registered irc_connected irc_001 irc_join irc_chan_sync irc_nick_sync irc_error irc_quit irc_disconnected ircd_daemon_nick ircd_daemon_eob )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd1->yield('register', 'all'); $ircd1->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $ircd1->add_peer( name => 'ircd2.poco.server.irc', pass => $pass, rpass => $pass, type => 'c' ); $ircd2->add_peer( name => 'ircd1.poco.server.irc', pass => $pass, rpass => $pass, type => 'r', auto => 'r', raddress => '127.0.0.1', rport => $port ); $ircd2->yield( 'register', 'all' ); $ircd2->yield( 'add_spoofed_nick', nick => 'oper', umode => 'o', ); $bot->yield(register => 'all'); $_[HEAP]->{listening_port} = $port; return; #$bot->delay([connect => { # nick => 'TestBot', # server => '127.0.0.1', # port => $port, # ircname => 'Test test bot', #}], 5); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd1->yield('shutdown'); $ircd2->yield('shutdown'); $bot->yield('shutdown'); } sub irc_registered { my ($irc) = $_[ARG0]; isa_ok($irc, 'POE::Component::IRC::State'); } sub irc_connected { pass('Connected'); } sub irc_001 { my ($heap, $server) = @_[HEAP, ARG0]; my $irc = $_[SENDER]->get_heap(); $heap->{server} = $server; pass('Logged in'); is($irc->server_name(), 'ircd1.poco.server.irc', 'Server Name Test'); is($irc->nick_name(), 'TestBot', 'Nick Name Test'); ok(!$irc->is_operator($irc->nick_name()), 'We are not an IRC op'); ok(!$irc->is_away($irc->nick_name()), 'We are not away'); $irc->yield('join','#testchannel'); return; } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = parse_user($who); my $irc = $sender->get_heap(); is($nick, $irc->nick_name(), 'JOINER Test'); is($where, '#testchannel', 'Joined Channel Test'); is($who, $irc->nick_long_form($nick), 'nick_long_form()'); my $chans = $irc->channels(); is(keys %$chans, 1, 'Correct number of channels'); is((keys %$chans)[0], $where, 'Correct channel name'); my @nicks = $irc->nicks(); TODO: { local $TODO = 'Sometimes there is a race condition'; is(@nicks, 2, 'Two nicks known'); } is($nicks[0], $nick, 'Nickname correct'); } sub join_after_split { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = parse_user($who); my $irc = $sender->get_heap(); is($nick, 'oper', 'oper joined'); ok(!defined $bot->{NETSPLIT}->{Users}->{'OPER!oper@ircd2.poco.server.irc'}, 'OPER!oper@ircd2.poco.server.irc' ); ok($irc->is_channel_member($where, $nick), 'Is Channel Member'); TODO: { local $TODO = 'Sometimes there is a race condition'; ok(!$irc->is_channel_operator($where, $nick), 'Is Not Channel Operator'); } $poe_kernel->yield( '_shutdown' ); } sub irc_nick_sync { my ($nick,$chan) = @_[ARG0,ARG1]; pass($_[STATE]); is($nick,'oper','Oper user was synced'); is($chan,'#testchannel','The channel synced was #testchannel'); return; } sub irc_chan_sync { my ($sender, $heap, $chan) = @_[SENDER, HEAP, ARG0]; my $irc = $sender->get_heap(); my ($nick, $user, $host) = parse_user($irc->nick_long_form($irc->nick_name())); my ($occupant) = grep { $_ eq 'TestBot' } $irc->channel_list($chan); is($occupant, 'TestBot', 'Channel Occupancy Test'); ok($irc->channel_creation_time($chan), 'Got channel creation time'); ok(!$irc->channel_limit($chan), 'There is no channel limit'); ok(!$irc->is_channel_mode_set($chan, 'i'), 'Channel mode i not set yet'); ok($irc->is_channel_member($chan, $nick), 'Is Channel Member'); ok(!$irc->is_channel_operator($chan, $nick), 'Is Not Channel Operator'); ok(!$irc->is_channel_halfop($chan, $nick), 'Is not channel halfop'); ok(!$irc->has_channel_voice($chan, $nick), 'Does not have channel voice'); ok($irc->ban_mask($chan, $nick), 'Ban Mask Test'); my @channels = $irc->nick_channels($nick); is(@channels, 1, 'Only present in one channel'); is($channels[0], $chan, 'The channel name matches'); my $info = $irc->nick_info($nick); is($info->{Nick}, $nick, 'nick_info() - Nick'); is($info->{User}, $user, 'nick_info() - User'); is($info->{Host}, $host, 'nick_info() - Host'); is($info->{Userhost}, "$user\@$host", 'nick_info() - Userhost'); is($info->{Hops}, 0, 'nick_info() - Hops'); is($info->{Real}, 'Test test bot', 'nick_info() - Realname'); is($info->{Server}, $heap->{server}, 'nick_info() - Server'); ok(!$info->{IRCop}, 'nick_info() - IRCop'); $ircd2->_daemon_cmd_squit( 'oper', 'ircd1.poco.server.irc' ); } sub irc_error { pass('irc_error'); } sub irc_disconnected { pass('irc_disconnected'); } # We registered for all events, this will produce some debug info. sub _default { my ($event, $args) = @_[ARG0 .. $#_]; my @output = ( "$event: " ); for my $arg (@$args) { if ( ref $arg eq 'ARRAY' ) { push( @output, '[' . join(', ', @$arg ) . ']' ); } else { push ( @output, "'$arg'" ); } } print join ' ', @output, "\n"; return 0; } sub ircd_daemon_nick { my $nickname = $_[ARG0]; return unless $nickname eq 'oper'; $ircd2->yield( daemon_cmd_join => $nickname => '#testchannel' ); return; } sub ircd_daemon_server { diag(join ' ', @_[ARG0..$#_]); return; } sub ircd_daemon_eob { my ($heap,$server) = @_[HEAP,ARG0]; return if $heap->{second}; $heap->{second}++; $bot->delay([connect => { nick => 'TestBot', server => '127.0.0.1', port => $heap->{listening_port}, ircname => 'Test test bot', }], 5); return; } sub irc_quit { ok(defined $bot->{NETSPLIT}->{Users}->{'OPER!oper@ircd2.poco.server.irc'}, 'OPER!oper@ircd2.poco.server.irc' ); $poe_kernel->state( 'irc_join', 'main', 'join_after_split' ); $ircd2->_daemon_cmd_connect( 'oper', 'ircd1.poco.server.irc' ); $_[HEAP]->{netjoin}=1; return; } libpoe-component-irc-perl-6.88+dfsg.orig/t/03_subclasses/02_qnet.t0000644000175000017500000000055112353530642024171 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC::Qnet; use Test::More tests => 1; my $bot = POE::Component::IRC::Qnet->spawn(); isa_ok($bot, 'POE::Component::IRC::Qnet'); $bot->yield('shutdown'); $poe_kernel->run(); POE::Session->create( package_states => [ main => ['_start'] ], ); sub _start { $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/03_subclasses/01_state.t0000644000175000017500000001463112353530642024345 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::Common qw(parse_user); use POE::Component::IRC::State; use POE::Component::Server::IRC; use Test::More 'no_plan'; my $bot = POE::Component::IRC::State->spawn(Flood => 1); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); isa_ok($bot, 'POE::Component::IRC::State'); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_registered irc_connected irc_001 irc_221 irc_305 irc_306 irc_whois irc_join irc_topic irc_chan_sync irc_user_mode irc_chan_mode irc_mode irc_error irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot', server => '127.0.0.1', port => $port, ircname => 'Test test bot', }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } sub irc_registered { my ($irc) = $_[ARG0]; isa_ok($irc, 'POE::Component::IRC::State'); } sub irc_connected { pass('Connected'); } sub irc_001 { my ($heap, $server) = @_[HEAP, ARG0]; my $irc = $_[SENDER]->get_heap(); $heap->{server} = $server; pass('Logged in'); is($irc->server_name(), 'poco.server.irc', 'Server Name Test'); is($irc->nick_name(), 'TestBot', 'Nick Name Test'); ok(!$irc->is_operator($irc->nick_name()), 'We are not an IRC op'); ok(!$irc->is_away($irc->nick_name()), 'We are not away'); $irc->yield(away => 'Gone for now'); $irc->yield(whois => 'TestBot'); } sub irc_305 { my $irc = $_[SENDER]->get_heap(); ok(!$irc->is_away($irc->nick_name()), 'We are back'); } sub irc_306 { my $irc = $_[SENDER]->get_heap(); ok($irc->is_away($irc->nick_name()), 'We are away now'); $irc->yield('away'); } sub irc_whois { my ($sender, $whois) = @_[SENDER, ARG0]; is($whois->{nick}, 'TestBot', 'Whois hash test'); $sender->get_heap()->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = parse_user($who); my $irc = $sender->get_heap(); is($nick, $irc->nick_name(), 'JOINER Test'); is($where, '#testchannel', 'Joined Channel Test'); is($who, $irc->nick_long_form($nick), 'nick_long_form()'); my $chans = $irc->channels(); is(keys %$chans, 1, 'Correct number of channels'); is((keys %$chans)[0], $where, 'Correct channel name'); my @nicks = $irc->nicks(); is(@nicks, 1, 'Only one nick known'); is($nicks[0], $nick, 'Nickname correct'); $irc->yield(topic => $where, 'Test topic'); } sub irc_topic { my ($sender, $heap, $chan, $topic) = @_[SENDER, HEAP, ARG1, ARG2]; my $irc = $sender->get_heap(); $heap->{got_topic}++; if ($heap->{got_topic} == 1) { my $topic_info = $irc->channel_topic($chan); is($topic, $topic_info->{Value}, 'Channel topic set'); $heap->{topic} = $topic_info; $irc->yield(topic => $chan, 'New test topic'); } elsif ($heap->{got_topic} == 2) { my $old_topic = $_[ARG3]; is_deeply($old_topic, $heap->{topic}, 'Got old topic'); } } sub irc_chan_sync { my ($sender, $heap, $chan) = @_[SENDER, HEAP, ARG0]; my $irc = $sender->get_heap(); my ($nick, $user, $host) = parse_user($irc->nick_long_form($irc->nick_name())); my ($occupant) = $irc->channel_list($chan); is($occupant, 'TestBot', 'Channel Occupancy Test'); ok($irc->channel_creation_time($chan), 'Got channel creation time'); ok(!$irc->channel_limit($chan), 'There is no channel limit'); ok(!$irc->is_channel_mode_set($chan, 'i'), 'Channel mode i not set yet'); ok($irc->is_channel_member($chan, $nick), 'Is Channel Member'); ok($irc->is_channel_operator($chan, $nick), 'Is Channel Operator'); ok(!$irc->is_channel_halfop($chan, $nick), 'Is not channel halfop'); ok(!$irc->has_channel_voice($chan, $nick), 'Does not have channel voice'); ok($irc->ban_mask($chan, $nick), 'Ban Mask Test'); my @channels = $irc->nick_channels($nick); is(@channels, 1, 'Only present in one channel'); is($channels[0], $chan, 'The channel name matches'); my $info = $irc->nick_info($nick); is($info->{Nick}, $nick, 'nick_info() - Nick'); is($info->{User}, $user, 'nick_info() - User'); is($info->{Host}, $host, 'nick_info() - Host'); is($info->{Userhost}, "$user\@$host", 'nick_info() - Userhost'); is($info->{Hops}, 0, 'nick_info() - Hops'); is($info->{Real}, 'Test test bot', 'nick_info() - Realname'); is($info->{Server}, $heap->{server}, 'nick_info() - Server'); ok(!$info->{IRCop}, 'nick_info() - IRCop'); $irc->yield(mode => $chan, '+l 100'); $heap->{mode_changed} = 1; } sub irc_chan_mode { my ($sender, $heap, $who, $chan, $mode) = @_[SENDER, HEAP, ARG0..ARG2]; my $irc = $sender->get_heap(); return if !$heap->{mode_changed}; $mode =~ s/\+//g; ok($irc->is_channel_mode_set($chan, $mode), "Channel Mode Set: $mode"); is($irc->channel_limit($chan), 100, 'Channel limit correct'); $irc->yield('quit'); } sub irc_user_mode { my ($sender, $who, $mode) = @_[SENDER, ARG0, ARG2]; my $irc = $sender->get_heap(); $mode =~ s/\+//g; ok($irc->is_user_mode_set($mode), "User Mode Set: $mode"); like($irc->umode(), qr/$mode/, 'Correct user mode in state'); } sub irc_mode { my $irc = $_[SENDER]->get_heap(); return if $_[ARG1] !~ /^\#/; } sub irc_221 { my $irc = $_[SENDER]->get_heap(); pass('State did a MODE query'); $irc->yield(mode => $irc->nick_name(), '+iw'); } sub irc_error { pass('irc_error'); } sub irc_disconnected { pass('irc_disconnected'); $poe_kernel->yield('_shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/03_subclasses/03_qnet_state.t0000644000175000017500000000057612353530642025401 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC::Qnet::State; use Test::More tests => 1; my $bot = POE::Component::IRC::Qnet::State->spawn(); isa_ok($bot, 'POE::Component::IRC::Qnet::State'); $bot->yield('shutdown'); $poe_kernel->run(); POE::Session->create( package_states => [ main => ['_start'] ], ); sub _start { $bot->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/03_subclasses/05_state_awaypoll.t0000644000175000017500000000654412353530642026265 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 10; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, AwayPoll => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_chan_sync irc_user_away irc_user_back irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name . ' logged in'); if ($irc == $bot1) { $irc->yield(join => '#testchannel'); } } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', $irc->nick_name . ' joined channel'); } sub irc_chan_sync { my ($sender, $where) = @_[SENDER, ARG0]; my $irc = $sender->get_heap(); is($where, '#testchannel', $irc->nick_name . ' synced channel'); if ($irc == $bot1) { $bot2->yield(join => $where); } else { $bot1->yield(away => "I'm gone now"); $bot2->yield(away => "I'm gone now"); } } sub irc_user_away { my ($sender, $nick) = @_[SENDER, ARG0]; my $irc = $sender->get_heap(); if ($irc == $bot1) { fail("Shouldn't get irc_user_away when AwayPoll is off"); } is($nick, $bot1->nick_name(), $bot1->nick_name() .' went away'); $bot1->yield('away'); $bot2->yield('away'); } sub irc_user_back { my ($sender, $nick) = @_[SENDER, ARG0]; my $irc = $sender->get_heap(); if ($irc == $bot1) { fail("Shouldn't get irc_user_back when AwayPoll is off"); } is($nick, $bot1->nick_name(), $bot1->nick_name() .' came back'); $_->yield('quit') for ($bot1, $bot2); } sub irc_disconnected { my ($kernel, $heap, $info) = @_[KERNEL, HEAP, ARG1]; pass($info->{Nick} . ' disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/05_regression/0000755000175000017500000000000012353530642022546 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/05_regression/01_dcc_chat_close.t0000644000175000017500000000636512353530642026162 0ustar gregoagregoa# This make sures that we can close a DCC connection right after sending # some data over it. The original bug was that the DCC plugin didn't post # a delayed close event correctly so it ended up checking if there was data # left to be sent on an undefined value rather than the wheel in question. use strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE::Component::IRC; use POE::Component::Server::IRC; use POE; use Test::More tests => 12; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done irc_dcc_chat irc_dcc_start )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); if ($nick eq $irc->nick_name()) { is($where, '#testchannel', 'Joined Channel Test'); if ($nick eq 'TestBot2') { $irc->yield(dcc => TestBot1 => CHAT => '' => '' => 5); } } } sub irc_dcc_request { my ($sender, $cookie) = @_[SENDER, ARG3]; pass('Got dcc request'); $sender->get_heap()->yield(dcc_accept => $cookie); } sub irc_dcc_start { my ($sender, $id) = @_[SENDER, ARG0]; my $irc = $sender->get_heap(); pass('DCC started'); if ($irc->nick_name() eq 'TestBot2') { $irc->yield(dcc_chat => $id => 'MOO'); $irc->yield(dcc_close => $id); } } sub irc_dcc_chat { my ($sender, $what) = @_[SENDER, ARG3]; is($what, 'MOO', 'DCC CHAT test'); } sub irc_dcc_done { pass('Got dcc close'); $_[SENDER]->get_heap()->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/inc/0000755000175000017500000000000012354017166020635 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/inc/Crypt/0000755000175000017500000000000012354017166021736 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/inc/Crypt/PasswdMD5.pm0000644000175000017500000000753312353530642024051 0ustar gregoagregoa# # Crypt::PasswdMD5: Module to provide an interoperable crypt() # function for modern Unix O/S. This is based on the code for # # /usr/src/libcrypt/crypt.c # # on a FreeBSD 2.2.5-RELEASE system, which included the following # notice. # # ---------------------------------------------------------------------------- # "THE BEER-WARE LICENSE" (Revision 42): # wrote this file. As long as you retain this notice you # can do whatever you want with this stuff. If we meet some day, and you think # this stuff is worth it, you can buy me a beer in return. Poul-Henning Kamp # ---------------------------------------------------------------------------- # # $Id: PasswdMD5.pm,v 1.3 2004/02/17 11:21:38 lem Exp $ # ################ package Crypt::PasswdMD5; $VERSION='1.3'; require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(unix_md5_crypt apache_md5_crypt); $Magic = q/$1$/; # Magic string $itoa64 = "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; use Digest::MD5; sub to64 { my ($v, $n) = @_; my $ret = ''; while (--$n >= 0) { $ret .= substr($itoa64, $v & 0x3f, 1); $v >>= 6; } $ret; } sub apache_md5_crypt { # change the Magic string to match the one used by Apache local $Magic = q/$apr1$/; unix_md5_crypt(@_); } sub unix_md5_crypt { my($pw, $salt) = @_; my $passwd; if ( defined $salt ) { $salt =~ s/^\Q$Magic//; # Take care of the magic string if # if present. $salt =~ s/^(.*)\$.*$/$1/; # Salt can have up to 8 chars... $salt = substr($salt, 0, 8); } else { $salt = ''; # in case no salt was proffered $salt .= substr($itoa64,int(rand(64)+1),1) while length($salt) < 8; } $ctx = new Digest::MD5; # Here we start the calculation $ctx->add($pw); # Original password... $ctx->add($Magic); # ...our magic string... $ctx->add($salt); # ...the salt... my ($final) = new Digest::MD5; $final->add($pw); $final->add($salt); $final->add($pw); $final = $final->digest; for ($pl = length($pw); $pl > 0; $pl -= 16) { $ctx->add(substr($final, 0, $pl > 16 ? 16 : $pl)); } # Now the 'weird' xform for ($i = length($pw); $i; $i >>= 1) { if ($i & 1) { $ctx->add(pack("C", 0)); } # This comes from the original version, # where a memset() is done to $final # before this loop. else { $ctx->add(substr($pw, 0, 1)); } } $final = $ctx->digest; # The following is supposed to make # things run slower. In perl, perhaps # it'll be *really* slow! for ($i = 0; $i < 1000; $i++) { $ctx1 = new Digest::MD5; if ($i & 1) { $ctx1->add($pw); } else { $ctx1->add(substr($final, 0, 16)); } if ($i % 3) { $ctx1->add($salt); } if ($i % 7) { $ctx1->add($pw); } if ($i & 1) { $ctx1->add(substr($final, 0, 16)); } else { $ctx1->add($pw); } $final = $ctx1->digest; } # Final xform $passwd = ''; $passwd .= to64(int(unpack("C", (substr($final, 0, 1))) << 16) | int(unpack("C", (substr($final, 6, 1))) << 8) | int(unpack("C", (substr($final, 12, 1)))), 4); $passwd .= to64(int(unpack("C", (substr($final, 1, 1))) << 16) | int(unpack("C", (substr($final, 7, 1))) << 8) | int(unpack("C", (substr($final, 13, 1)))), 4); $passwd .= to64(int(unpack("C", (substr($final, 2, 1))) << 16) | int(unpack("C", (substr($final, 8, 1))) << 8) | int(unpack("C", (substr($final, 14, 1)))), 4); $passwd .= to64(int(unpack("C", (substr($final, 3, 1))) << 16) | int(unpack("C", (substr($final, 9, 1))) << 8) | int(unpack("C", (substr($final, 15, 1)))), 4); $passwd .= to64(int(unpack("C", (substr($final, 4, 1))) << 16) | int(unpack("C", (substr($final, 10, 1))) << 8) | int(unpack("C", (substr($final, 5, 1)))), 4); $passwd .= to64(int(unpack("C", substr($final, 11, 1))), 2); $final = ''; $Magic . $salt . q/$/ . $passwd; } 1; __END__ libpoe-component-irc-perl-6.88+dfsg.orig/t/inc/Net/0000755000175000017500000000000012354017166021363 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/inc/Net/Netmask.pm0000644000175000017500000003043612353530642023327 0ustar gregoagregoa# Copyright (C) 1998-2006, David Muir Sharnoff package Net::Netmask; use vars qw($VERSION); $VERSION = 1.9015; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(findNetblock findOuterNetblock findAllNetblock cidrs2contiglists range2cidrlist sort_by_ip_address dumpNetworkTable sort_network_blocks cidrs2cidrs cidrs2inverse); @EXPORT_OK = (@EXPORT, qw(int2quad quad2int %quadmask2bits %quadhostmask2bits imask sameblock cmpblocks contains)); my $remembered = {}; my %imask2bits; my %size2bits; my @imask; # our %quadmask2bits; # our %quadhostmask2bits; use vars qw($error $debug %quadmask2bits %quadhostmask2bits); $debug = 1; use strict; use warnings FATAL => 'all'; use Carp; use overload '""' => \&desc, '<=>' => \&cmp_net_netmask_block, 'cmp' => \&cmp_net_netmask_block, 'fallback' => 1; sub new { my ($package, $net, $mask) = @_; $mask = '' unless defined $mask; my $base; my $bits; my $ibase; undef $error; if ($net =~ m,^(\d+\.\d+\.\d+\.\d+)/(\d+)$,) { ($base, $bits) = ($1, $2); } elsif ($net =~ m,^(\d+\.\d+\.\d+\.\d+)[:/](\d+\.\d+\.\d+\.\d+)$,) { $base = $1; my $quadmask = $2; if (exists $quadmask2bits{$quadmask}) { $bits = $quadmask2bits{$quadmask}; } else { $error = "illegal netmask: $quadmask"; } } elsif ($net =~ m,^(\d+\.\d+\.\d+\.\d+)[#](\d+\.\d+\.\d+\.\d+)$,) { $base = $1; my $hostmask = $2; if (exists $quadhostmask2bits{$hostmask}) { $bits = $quadhostmask2bits{$hostmask}; } else { $error = "illegal hostmask: $hostmask"; } } elsif (($net =~ m,^\d+\.\d+\.\d+\.\d+$,) && ($mask =~ m,\d+\.\d+\.\d+\.\d+$,)) { $base = $net; if (exists $quadmask2bits{$mask}) { $bits = $quadmask2bits{$mask}; } else { $error = "illegal netmask: $mask"; } } elsif (($net =~ m,^\d+\.\d+\.\d+\.\d+$,) && ($mask =~ m,0x[a-z0-9]+,i)) { $base = $net; my $imask = hex($mask); if (exists $imask2bits{$imask}) { $bits = $imask2bits{$imask}; } else { $error = "illegal netmask: $mask ($imask)"; } } elsif ($net =~ /^\d+\.\d+\.\d+\.\d+$/ && ! $mask) { ($base, $bits) = ($net, 32); } elsif ($net =~ /^\d+\.\d+\.\d+$/ && ! $mask) { ($base, $bits) = ("$net.0", 24); } elsif ($net =~ /^\d+\.\d+$/ && ! $mask) { ($base, $bits) = ("$net.0.0", 16); } elsif ($net =~ /^\d+$/ && ! $mask) { ($base, $bits) = ("$net.0.0.0", 8); } elsif ($net =~ m,^(\d+\.\d+\.\d+)/(\d+)$,) { ($base, $bits) = ("$1.0", $2); } elsif ($net =~ m,^(\d+\.\d+)/(\d+)$,) { ($base, $bits) = ("$1.0.0", $2); } elsif ($net =~ m,^(\d+)/(\d+)$,) { ($base, $bits) = ("$1.0.0.0", $2); } elsif ($net eq 'default' || $net eq 'any') { ($base, $bits) = ("0.0.0.0", 0); } elsif ($net =~ m,^(\d+\.\d+\.\d+\.\d+)\s*-\s*(\d+\.\d+\.\d+\.\d+)$,) { # whois format $ibase = quad2int($1); my $end = quad2int($2); $error = "illegal dotted quad: $net" unless defined($ibase) && defined($end); my $diff = ($end || 0) - ($ibase || 0) + 1; $bits = $size2bits{$diff}; $error = "could not find exact fit for $net" if ! defined $error && ( ! defined $bits || ($ibase & ~$imask[$bits])); } else { $error = "could not parse $net"; $error .= " $mask" if $mask; } carp $error if $error && $debug; $ibase = quad2int($base || 0) unless defined $ibase; unless (defined($ibase) || defined($error)) { $error = "could not parse $net"; $error .= " $mask" if $mask; } $ibase &= $imask[$bits] if defined $ibase && defined $bits; $bits = 0 unless $bits; if ($bits > 32) { $error = "illegal number of bits: $bits" unless $error; $bits = 32; } return bless { 'IBASE' => $ibase, 'BITS' => $bits, ( $error ? ( 'ERROR' => $error ) : () ), }; } sub new2 { local($debug) = 0; my $net = new(@_); return undef if $error; return $net; } sub errstr { return $error; } sub debug { my $this = shift; return (@_ ? $debug = shift : $debug) } sub base { my ($this) = @_; return int2quad($this->{'IBASE'}); } sub bits { my ($this) = @_; return $this->{'BITS'}; } sub size { my ($this) = @_; return 2**(32- $this->{'BITS'}); } sub next { my ($this) = @_; int2quad($this->{'IBASE'} + $this->size()); } sub broadcast { my($this) = @_; int2quad($this->{'IBASE'} + $this->size() - 1); } *first = \&base; *last = \&broadcast; sub desc { return int2quad($_[0]->{'IBASE'}).'/'.$_[0]->{'BITS'}; } sub imask { return (2**32 -(2** (32- $_[0]))); } sub mask { my ($this) = @_; return int2quad ( $imask[$this->{'BITS'}]); } sub hostmask { my ($this) = @_; return int2quad ( ~ $imask[$this->{'BITS'}]); } sub nth { my ($this, $index, $bitstep) = @_; my $size = $this->size(); my $ibase = $this->{'IBASE'}; $bitstep = 32 unless $bitstep; my $increment = 2**(32-$bitstep); $index *= $increment; $index += $size if $index < 0; return undef if $index < 0; return undef if $index >= $size; return int2quad($ibase+$index); } sub enumerate { my ($this, $bitstep) = @_; $bitstep = 32 unless $bitstep; my $size = $this->size(); my $increment = 2**(32-$bitstep); my @ary; my $ibase = $this->{'IBASE'}; for (my $i = 0; $i < $size; $i += $increment) { push(@ary, int2quad($ibase+$i)); } return @ary; } sub inaddr { my ($this) = @_; my $ibase = $this->{'IBASE'}; my $blocks = int($this->size()/256); return (join('.',unpack('xC3', pack('V', $ibase))).".in-addr.arpa", $ibase%256, $ibase%256+$this->size()-1) if $blocks == 0; my @ary; for (my $i = 0; $i < $blocks; $i++) { push(@ary, join('.',unpack('xC3', pack('V', $ibase+$i*256))) .".in-addr.arpa", 0, 255); } return @ary; } sub tag { my $this = shift; my $tag = shift; my $val = $this->{'T'.$tag}; $this->{'T'.$tag} = $_[0] if @_; return $val; } sub quad2int { my @bytes = split(/\./,$_[0]); return undef unless @bytes == 4 && ! grep {!(/\d+$/ && $_<256)} @bytes; return unpack("N",pack("C4",@bytes)); } sub int2quad { return join('.',unpack('C4', pack("N", $_[0]))); } sub storeNetblock { my ($this, $t) = @_; $t = $remembered unless $t; my $base = $this->{'IBASE'}; $t->{$base} = [] unless exists $t->{$base}; my $mb = maxblock($this); my $b = $this->{'BITS'}; my $i = $b - $mb; $t->{$base}->[$i] = $this; } sub deleteNetblock { my ($this, $t) = @_; $t = $remembered unless $t; my $base = $this->{'IBASE'}; my $mb = maxblock($this); my $b = $this->{'BITS'}; my $i = $b - $mb; return unless defined $t->{$base}; undef $t->{$base}->[$i]; for my $x (@{$t->{$base}}) { return if $x; } delete $t->{$base}; } sub findNetblock { my ($ipquad, $t) = @_; $t = $remembered unless $t; my $ip = quad2int($ipquad); my %done; for (my $b = 32; $b >= 0; $b--) { my $nb = $ip & $imask[$b]; next unless exists $t->{$nb}; my $mb = imaxblock($nb, 32); next if $done{$mb}++; my $i = $b - $mb; confess "$mb, $b, $ipquad, $nb" if ($i < 0 or $i > 32); while ($i >= 0) { return $t->{$nb}->[$i] if defined $t->{$nb}->[$i]; $i--; } } return undef; } sub findOuterNetblock { my ($ipquad, $t) = @_; $t = $remembered unless $t; my $ip; my $mask; if (ref($ipquad)) { $ip = $ipquad->{IBASE}; $mask = $ipquad->{BITS}; } else { $ip = quad2int($ipquad); $mask = 32; } for (my $b = 0; $b <= $mask; $b++) { my $nb = $ip & $imask[$b];; next unless exists $t->{$nb}; my $mb = imaxblock($nb, $mask); my $i = $b - $mb; confess "$mb, $b, $ipquad, $nb" if $i < 0; confess "$mb, $b, $ipquad, $nb" if $i > 32; while ($i >= 0) { return $t->{$nb}->[$i] if defined $t->{$nb}->[$i]; $i--; } } return undef; } sub findAllNetblock { my ($ipquad, $t) = @_; $t = $remembered unless $t; my @ary ; my $ip = quad2int($ipquad); my %done; for (my $b = 32; $b >= 0; $b--) { my $nb = $ip & $imask[$b]; next unless exists $t->{$nb}; my $mb = imaxblock($nb, 32); next if $done{$mb}++; my $i = $b - $mb; confess "$mb, $b, $ipquad, $nb" if $i < 0; confess "$mb, $b, $ipquad, $nb" if $i > 32; while ($i >= 0) { push(@ary, $t->{$nb}->[$i]) if defined $t->{$nb}->[$i]; $i--; } } return @ary; } sub dumpNetworkTable { my ($t) = @_; $t = $remembered unless $t; my @ary; foreach my $base (keys %$t) { push(@ary, grep (defined($_), @{$t->{base}})); for my $x (@{$t->{$base}}) { push(@ary, $x) if defined $x; } } return sort @ary; } sub checkNetblock { my ($this, $t) = @_; $t = $remembered unless $t; my $base = $this->{'IBASE'}; my $mb = maxblock($this); my $b = $this->{'BITS'}; my $i = $b - $mb; return defined $t->{$base}->[$i]; } sub match { my ($this, $ip) = @_; my $i = quad2int($ip); my $imask = $imask[$this->{BITS}]; if (($i & $imask) == $this->{IBASE}) { return (($i & ~ $imask) || "0 "); } else { return 0; } } sub maxblock { my ($this) = @_; return imaxblock($this->{'IBASE'}, $this->{'BITS'}); } sub nextblock { my ($this, $index) = @_; $index = 1 unless defined $index; my $newblock = bless { IBASE => $this->{IBASE} + $index * (2**(32- $this->{BITS})), BITS => $this->{BITS}, }; return undef if $newblock->{IBASE} >= 2**32; return undef if $newblock->{IBASE} < 0; return $newblock; } sub imaxblock { my ($ibase, $tbit) = @_; confess unless defined $ibase; while ($tbit > 0) { my $im = $imask[$tbit-1]; last if (($ibase & $im) != $ibase); $tbit--; } return $tbit; } sub range2cidrlist { my ($startip, $endip) = @_; my $start = quad2int($startip); my $end = quad2int($endip); ($start, $end) = ($end, $start) if $start > $end; return irange2cidrlist($start, $end); } sub irange2cidrlist { my ($start, $end) = @_; my @result; while ($end >= $start) { my $maxsize = imaxblock($start, 32); my $maxdiff = 32 - int(log($end - $start + 1)/log(2)); $maxsize = $maxdiff if $maxsize < $maxdiff; push (@result, bless { 'IBASE' => $start, 'BITS' => $maxsize }); $start += 2**(32-$maxsize); } return @result; } sub cidrs2contiglists { my (@cidrs) = sort_network_blocks(@_); my @result; while (@cidrs) { my (@r) = shift(@cidrs); my $max = $r[0]->{IBASE} + $r[0]->size; while ($cidrs[0] && $cidrs[0]->{IBASE} <= $max) { my $nm = $cidrs[0]->{IBASE} + $cidrs[0]->size; $max = $nm if $nm > $max; push(@r, shift(@cidrs)); } push(@result, [@r]); } return @result; } sub cidrs2cidrs { my (@cidrs) = sort_network_blocks(@_); my @result; while (@cidrs) { my (@r) = shift(@cidrs); my $max = $r[0]->{IBASE} + $r[0]->size; while ($cidrs[0] && $cidrs[0]->{IBASE} <= $max) { my $nm = $cidrs[0]->{IBASE} + $cidrs[0]->size; $max = $nm if $nm > $max; push(@r, shift(@cidrs)); } my $start = $r[0]->{IBASE}; my $end = $max - 1; push(@result, irange2cidrlist($start, $end)); } return @result; } sub cidrs2inverse { my $outer = shift; $outer = __PACKAGE__->new2($outer) || croak($error) unless ref($outer); my (@cidrs) = cidrs2cidrs(@_); my $first = $outer->{IBASE}; my $last = $first + $outer->size() -1; shift(@cidrs) while $cidrs[0] && $cidrs[0]->{IBASE} + $cidrs[0]->size < $first; my @r; while (@cidrs && $first <= $last) { if ($first < $cidrs[0]->{IBASE}) { if ($last <= $cidrs[0]->{IBASE}-1) { return (@r, irange2cidrlist($first, $last)); } push(@r, irange2cidrlist($first, $cidrs[0]->{IBASE}-1)); } last if $cidrs[0]->{IBASE} > $last; $first = $cidrs[0]->{IBASE} + $cidrs[0]->size; shift(@cidrs); } if ($first <= $last) { push(@r, irange2cidrlist($first, $last)); } return @r; } sub by_net_netmask_block { $a->{'IBASE'} <=> $b->{'IBASE'} || $a->{'BITS'} <=> $b->{'BITS'}; } sub sameblock { return ! cmpblocks(@_); } sub cmpblocks { my $this = shift; my $class = ref $this; my $other = (ref $_[0]) ? shift : $class->new(@_); return cmp_net_netmask_block($this, $other); } sub contains { my $this = shift; my $class = ref $this; my $other = (ref $_[0]) ? shift : $class->new(@_); return 0 if $this->{IBASE} > $other->{IBASE}; return 0 if $this->{BITS} > $other->{BITS}; return 0 if $other->{IBASE} > $this->{IBASE} + $this->size -1; return 1; } sub cmp_net_netmask_block { return ($_[0]->{IBASE} <=> $_[1]->{IBASE} || $_[0]->{BITS} <=> $_[1]->{BITS}); } sub sort_network_blocks { return map $_->[0], sort { $a->[1] <=> $b->[1] || $a->[2] <=> $b->[2] } map [ $_, $_->{IBASE}, $_->{BITS} ], @_; } sub sort_by_ip_address { return map $_->[0], sort { $a->[1] cmp $b->[1] } map [ $_, pack("C4",split(/\./,$_)) ], @_; } BEGIN { for (my $i = 0; $i <= 32; $i++) { $imask[$i] = imask($i); $imask2bits{$imask[$i]} = $i; $quadmask2bits{int2quad($imask[$i])} = $i; $quadhostmask2bits{int2quad(~$imask[$i])} = $i; $size2bits{ 2**(32-$i) } = $i; } } 1; libpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/0000755000175000017500000000000012353530642021256 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/0000755000175000017500000000000012353530642023220 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/Server/0000755000175000017500000000000012354017166024470 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/Server/IRC/0000755000175000017500000000000012353530642025103 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/Server/IRC/Plugin/0000755000175000017500000000000012353530642026341 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/Server/IRC/Plugin/OperServ.pm0000644000175000017500000001066412353530642030453 0ustar gregoagregoapackage POE::Component::Server::IRC::Plugin::OperServ; BEGIN { $POE::Component::Server::IRC::Plugin::OperServ::AUTHORITY = 'cpan:HINRIK'; } BEGIN { $POE::Component::Server::IRC::Plugin::OperServ::VERSION = '1.52'; } use strict; use warnings; use POE::Component::Server::IRC::Plugin qw(:ALL); sub new { my ($package, %args) = @_; return bless \%args, $package; } sub PCSI_register { my ($self, $ircd) = splice @_, 0, 2; $ircd->plugin_register($self, 'SERVER', qw(daemon_privmsg daemon_join)); $ircd->yield( 'add_spoofed_nick', { nick => 'OperServ', umode => 'Doi', ircname => 'The OperServ bot', }, ); return 1; } sub PCSI_unregister { return 1; } sub IRCD_daemon_privmsg { my ($self, $ircd) = splice @_, 0, 2; my $nick = (split /!/, ${ $_[0] })[0]; return PCSI_EAT_NONE if !$ircd->state_user_is_operator($nick); my $request = ${ $_[2] }; SWITCH: { if (my ($chan) = $request =~ /^clear\s+(#.+)\s*$/i) { last SWITCH if !$ircd->state_chan_exists($chan); $ircd->yield('daemon_cmd_sjoin', 'OperServ', $chan); last SWITCH; } if (my ($chan) = $request =~ /^join\s+(#.+)\s*$/i) { last SWITCH if !$ircd->state_chan_exists($chan); $ircd->yield('daemon_cmd_join', 'OperServ', $chan); last SWITCH; } if (my ($chan) = $request =~ /^part\s+(#.+)\s*$/i) { last SWITCH unless $ircd->state_chan_exists($chan); $ircd->yield('daemon_cmd_part', 'OperServ', $chan); last SWITCH; } if (my ($chan, $mode) = $request =~ /^mode\s+(#.+)\s+(.+)\s*$/i) { last SWITCH if !$ircd->state_chan_exists($chan); $ircd->yield('daemon_cmd_mode', 'OperServ', $chan, $mode); last SWITCH; } if (my ($chan, $target) = $request =~ /^op\s+(#.+)\s+(.+)\s*$/i) { last SWITCH unless $ircd->state_chan_exists($chan); $ircd->daemon_server_mode($chan, '+o', $target); } } return PCSI_EAT_NONE; } sub IRCD_daemon_join { my ($self, $ircd) = splice @_, 0, 2; my $nick = (split /!/, ${ $_[0] })[0]; if (!$ircd->state_user_is_operator($nick) || $nick eq 'OperServ') { return PCSI_EAT_NONE; } my $channel = ${ $_[1] }; return PCSI_EAT_NONE if $ircd->state_is_chan_op($nick, $channel); $ircd->daemon_server_mode($channel, '+o', $nick); return PCSI_EAT_NONE; } 1; =encoding utf8 =head1 NAME POE::Component::Server::IRC::Plugin::OperServ - An OperServ plugin for POE::Component::Server::IRC =head1 SYNOPSIS use POE::Component::Server::IRC::Plugin::OperServ; $ircd->plugin_add( 'OperServ', POE::Component::Server::IRC::Plugin::OperServ->new(), ); =head1 DESCRIPTION POE::Component::Server::IRC::Plugin::OperServ is a L plugin which provides simple operator services. This plugin provides a server user called OperServ. OperServ accepts PRIVMSG commands from operators. /msg OperServ =head1 METHODS =head2 C Returns a plugin object suitable for feeding to L's C method. =head1 COMMANDS The following commands are accepted: =head2 clear CHANNEL The OperServ will remove all channel modes on the indicated channel, including all users' +ov flags. The timestamp of the channel will be reset and the OperServ will join that channel with +o. =head2 join CHANNEL The OperServ will simply join the channel you specify with +o. =head2 part CHANNEL The OperServ will part (leave) the channel specified. =head2 mode CHANNEL MODE The OperServ will set the channel mode you tell it to. You can also remove the channel mode by prefixing the mode with a '-' (minus) sign. =head2 op CHANNEL USER The OperServ will give +o to any user on a channel you specify. OperServ does not need to be in that channel (as this is mostly a server hack). Whenever the OperServ joins a channel (which you specify with the join command) it will automatically gain +o. =head1 AUTHOR Chris 'BinGOs' Williams =head1 LICENSE Copyright C<(c)> Chris Williams This module may be used, modified, and distributed under the same terms as Perl itself. Please see the license that came with your Perl distribution for details. =head1 SEE ALSO L =cut libpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/Server/IRC/Plugin/Auth.pm0000644000175000017500000002017512353530642027605 0ustar gregoagregoapackage POE::Component::Server::IRC::Plugin::Auth; BEGIN { $POE::Component::Server::IRC::Plugin::Auth::AUTHORITY = 'cpan:HINRIK'; } BEGIN { $POE::Component::Server::IRC::Plugin::Auth::VERSION = '1.52'; } use strict; use warnings; use Carp 'croak'; use POE; use POE::Component::Client::Ident::Agent; use POE::Component::Client::DNS; use POE::Component::Server::IRC::Plugin 'PCSI_EAT_NONE'; sub new { my ($package, %args) = @_; return bless \%args, $package; } sub PCSI_register { my ($self, $ircd) = splice @_, 0, 2; $self->{ircd} = $ircd; POE::Session->create( object_states => [ $self => [qw( _start resolve_hostname resolve_ident got_hostname )], $self => { ident_agent_reply => 'got_ident', ident_agent_error => 'got_ident_error', } ], ); $ircd->plugin_register($self, 'SERVER', qw(connection)); return 1; } sub PCSI_unregister { my ($self, $ircd) = splice @_, 0, 2; $self->{resolver}->shutdown() if $self->{resolver}; return 1; } sub _start { my ($self, $session) = @_[OBJECT, SESSION]; $self->{session_id} = $session->ID; $self->{resolver} = POE::Component::Client::DNS->spawn( Timeout => 10, ); return; } sub IRCD_connection { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id, $peeraddr, $peerport, $sockaddr, $sockport, $needs_auth) = map { $$_ } @_; return PCSI_EAT_NONE if !$needs_auth; return PCSI_EAT_NONE if !$ircd->connection_exists($conn_id); $self->{conns}{$conn_id} = { hostname => '', ident => '', }; $ircd->send_output( { command => 'NOTICE', params => ['AUTH', '*** Checking Ident'], }, $conn_id, ); $ircd->send_output( { command => 'NOTICE', params => ['AUTH', '*** Checking Hostname'], }, $conn_id, ); if ($peeraddr =~ /^127\./) { $ircd->send_output( { command => 'NOTICE', params => ['AUTH', '*** Found your hostname'] }, $conn_id, ); $self->{conns}{$conn_id}{hostname} = 'localhost'; $self->_auth_done($conn_id); } else { $poe_kernel->call( $self->{session_id}, 'resolve_hostname', $conn_id, $peeraddr, ); } $poe_kernel->call( $self->{session_id}, 'resolve_ident', $conn_id, $peeraddr, $peerport, $sockaddr, $sockport, ); return PCSI_EAT_NONE; } sub resolve_hostname { my ($self, $conn_id, $peeraddr) = @_[OBJECT, ARG0, ARG1]; my $response = $self->{resolver}->resolve( event => 'got_hostname', host => $peeraddr, type => 'PTR', context => { conn_id => $conn_id, peeraddr => $peeraddr, }, ); $poe_kernel->call('got_hostname', $response) if $response; return; } sub resolve_ident { my ($kernel, $self, $conn_id, $peeraddr, $peerport, $sockaddr, $sockport) = @_[KERNEL, OBJECT, ARG0..$#_]; POE::Component::Client::Ident::Agent->spawn( PeerAddr => $peeraddr, PeerPort => $peerport, SockAddr => $sockaddr, SockPort => $sockport, BuggyIdentd => 1, TimeOut => 10, Reference => $conn_id, ); return; } sub got_hostname { my ($kernel, $self, $response) = @_[KERNEL, OBJECT, ARG0]; my $conn_id = $response->{context}{conn_id}; my $ircd = $self->{ircd}; if (!$ircd->connection_exists($conn_id)) { delete $self->{conns}{$conn_id}; return; } my $fail = sub { $ircd->send_output( { command => 'NOTICE', params => [ 'AUTH', "*** Couldn\'t look up your hostname", ], }, $conn_id, ); if ($self->{conns}{$conn_id}{done} == 2) { $self->_auth_done($conn_id); } }; return $fail->() if !defined $response->{response}; my @answers = $response->{response}->answer(); return $fail->() if !@answers; for my $answer (@answers) { my $context = $response->{context}; $context->{hostname} = $answer->rdatastr(); chop $context->{hostname} if $context->{hostname} =~ /\.$/; my $query = $self->{resolver}->resolve( event => 'got_ip', host => $answer->rdatastr(), context => $context, type => 'A', ); if (defined $query) { $kernel->call($self->{session_id}, 'got_ip', $query); } } return; } sub got_ip { my ($kernel, $self, $response) = @_[KERNEL, OBJECT, ARG0]; my $conn_id = $response->{context}{conn_id}; my $ircd = $self->{ircd}; if (!$ircd->connection_exists($conn_id)) { delete $self->{conns}{$conn_id}; return; } my $fail = sub { $ircd->send_output( { command => 'NOTICE', params => [ 'AUTH', "*** Couldn't look up your hostname", ], }, $conn_id, ); $self->_auth_done($conn_id); }; return $fail->() if !defined $response->{response}; my @answers = $response->{response}->answer(); return $fail->() if !@answers; my $peeraddress = $response->{context}{peeraddress}; my $hostname = $response->{context}{hostname}; for my $answer (@answers) { if ($answer->rdatastr() eq $peeraddress) { $ircd->send_output( { command => 'NOTICE', params => ['AUTH', '*** Found your hostname'], }, $conn_id, ); $self->{conns}{$conn_id}{hostname} = $hostname; $self->_auth_done($conn_id); return; } } $ircd->send_output( { command => 'NOTICE', params => [ 'AUTH', '*** Your forward and reverse DNS do not match', ], }, $conn_id, ); $self->_auth_done($conn_id); return; } sub _auth_done { my ($self, $conn_id) = @_; $self->{conns}{$conn_id}{done}++; return if $self->{conns}{$conn_id}{done} != 2; my $auth = delete $self->{conns}{$conn_id}; $self->{ircd}->send_event( 'auth_done', $conn_id, { ident => $auth->{ident}, hostname => $auth->{hostname}, }, ); return; } sub got_ident_error { my ($kernel, $self, $ref, $error) = @_[KERNEL, OBJECT, ARG0, ARG1]; my $conn_id = $ref->{Reference}; my $ircd = $self->{ircd}; if (!$ircd->connection_exists($conn_id)) { delete $self->{conns}{$conn_id}; return; } $ircd->send_output( { command => 'NOTICE', params => ['AUTH', "*** No Ident response"], }, $conn_id, ); $self->_auth_done($conn_id); return; } sub got_ident { my ($kernel, $self, $ref, $opsys, $other) = @_[KERNEL, OBJECT, ARG0, ARG1, ARG2]; my $conn_id = $ref->{Reference}; my $ircd = $self->{ircd}; if (!$ircd->connection_exists($conn_id)) { delete $self->{conns}{$conn_id}; return; } my $ident = ''; $ident = $other if uc $opsys ne 'OTHER'; $ircd->send_output( { command => 'NOTICE', params => ['AUTH', "*** Got Ident response"], }, $conn_id, ); $self->{conns}{$conn_id}{ident} = $ident; $self->_auth_done($conn_id); return; } 1; =encoding utf8 =head1 NAME POE::Component::Server::IRC::Plugin::Auth - Authentication subsystem of POE::Component::Server::IRC::Backend =head1 DESCRIPTION This module is used internally by L. No need for you to use it. =head1 AUTHOR Hinrik Ern SigurEsson Chris 'BinGOs' Williams =cut libpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/Server/IRC/Common.pm0000644000175000017500000000576612353530642026707 0ustar gregoagregoapackage POE::Component::Server::IRC::Common; BEGIN { $POE::Component::Server::IRC::Common::AUTHORITY = 'cpan:HINRIK'; } BEGIN { $POE::Component::Server::IRC::Common::VERSION = '1.52'; } use strict; use warnings FATAL => 'all'; use Crypt::PasswdMD5; require Exporter; use base qw(Exporter); our @EXPORT_OK = qw(mkpasswd chkpasswd); our %EXPORT_TAGS = ( ALL => [@EXPORT_OK] ); sub mkpasswd { my ($plain, %opts) = @_; return if !defined $plain || !length $plain; $opts{lc $_} = delete $opts{$_} for keys %opts; return unix_md5_crypt($plain) if $opts{md5}; return apache_md5_crypt($plain) if $opts{apache}; my $salt = join '', ('.','/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]; return crypt($plain, $salt); } sub chkpasswd { my ($pass, $chk) = @_; return if !defined $pass || !length $pass; return if !defined $chk || !length $chk; my $md5 = '$1$'; my $apr = '$apr1$'; if (index($chk,$apr) == 0) { my $salt = $chk; $salt =~ s/^\Q$apr//; $salt =~ s/^(.*)\$/$1/; $salt = substr( $salt, 0, 8 ); return 1 if apache_md5_crypt($pass, $salt) eq $chk; } elsif ( index($chk,$md5) == 0 ) { my $salt = $chk; $salt =~ s/^\Q$md5//; $salt =~ s/^(.*)\$/$1/; $salt = substr( $salt, 0, 8 ); return 1 if unix_md5_crypt($pass, $salt) eq $chk; } return 1 if crypt( $pass, $chk ) eq $chk; return 1 if $pass eq $chk; return; } 1; =encoding utf8 =head1 NAME POE::Component::Server::IRC::Common - provides a set of common functions for the POE::Component::Server::IRC suite. =head1 SYNOPSIS use strict; use warnings; use POE::Component::Server::IRC::Common qw( :ALL ); my $passwd = mkpasswd( 'moocow' ); =head1 DESCRIPTION POE::Component::IRC::Common provides a set of common functions for the L suite. =head1 FUNCTIONS =head2 C Takes one mandatory argument a plain string to 'encrypt'. If no further options are specified it uses C to generate the password. Specifying 'md5' option uses L's C function to generate the password. Specifying 'apache' uses Crypt::PasswdMD5 C function to generate the password. my $passwd = mkpasswd( 'moocow' ); # vanilla crypt() my $passwd = mkpasswd( 'moocow', md5 => 1 ) # unix_md5_crypt() my $passwd = mkpasswd( 'moocow', apache => 1 ) # apache_md5_crypt() =head2 C Takes two mandatory arguments, a password string and something to check that password against. The function first tries md5 comparisons (UNIX and Apache), then C and finally plain-text password check. =head1 AUTHOR Chris 'BinGOs' Williams =head1 LICENSE Copyright E Chris Williams This module may be used, modified, and distributed under the same terms as Perl itself. Please see the license that came with your Perl distribution for details. =head1 SEE ALSO L =cut libpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/Server/IRC/Plugin.pm0000644000175000017500000001322212353530642026677 0ustar gregoagregoapackage POE::Component::Server::IRC::Plugin; BEGIN { $POE::Component::Server::IRC::Plugin::AUTHORITY = 'cpan:HINRIK'; } BEGIN { $POE::Component::Server::IRC::Plugin::VERSION = '1.52'; } use strict; use warnings FATAL => 'all'; require Exporter; use base qw(Exporter); our @EXPORT_OK = qw(PCSI_EAT_NONE PCSI_EAT_CLIENT PCSI_EAT_PLUGIN PCSI_EAT_ALL); our %EXPORT_TAGS = ( ALL => [@EXPORT_OK] ); use constant { PCSI_EAT_NONE => 1, PCSI_EAT_CLIENT => 2, PCSI_EAT_PLUGIN => 3, PCSI_EAT_ALL => 4, }; 1; =encoding utf8 =head1 NAME POE::Component::Server::IRC::Plugin - Provides plugin documentation for POE::Component::Server::IRC. =head1 DESCRIPTION This is the document coders/users should refer to when using/developing plugins for POE::Component::Server::IRC. The plugin system works by letting coders hook into aspects of POE::Component::Server::IRC::Backend. More details are found in the docs for L. The general architecture of using the plugins should be: # Import the stuff... use POE; use POE::Component::Server::IRC::Backend; use POE::Component::Server::IRC::Plugin::ExamplePlugin; # Create our session here POE::Session->create( ... ); # Create the IRC session here my $irc = POE::Component::Server::IRC::Backend->spawn() or die 'Nooo!'; # Create the plugin # Of course it could be something like $plugin = MyPlugin->new(); my $plugin = POE::Component::Server::IRC::Plugin::ExamplePlugin->new( ... ); # Hook it up! $irc->plugin_add( 'ExamplePlugin', $plugin ); # OOPS, we lost the plugin object! my $pluginobj = $irc->plugin_get( 'ExamplePlugin' ); # We want a list of plugins and objects my $hashref = $irc->plugin_list(); # Oh! We want a list of plugin aliases. my @aliases = keys %{ $irc->plugin_list() }; # Ah, we want to remove the plugin $plugin = $irc->plugin_del( 'ExamplePlugin' ); The plugins themselves will conform to the standard API described here. What they can do is limited only by imagination and the IRC RFC's ;) package POE::Component::Server::IRC::ExamplePlugin; # Import the constants use POE::Component::Server::IRC::Plugin qw( :ALL ); # Our constructor sub new { # ... } # Required entry point for POE::Component::Server::IRC::Backend sub PCSI_register { my ($self, $irc) = @_; # Register events we are interested in $irc->plugin_register( $self, 'SERVER', qw(connection) ); # Return success return 1; } # Required exit point for PoCo-Server-IRC sub PCSI_unregister { my ($self, $irc) = @_; # PCSIB will automatically unregister events for the plugin # Do some cleanup... # Return success return 1; } # Registered events will be sent to methods starting with IRC_ # If the plugin registered for SERVER - irc_355 sub IRCD_connection { my ($self, $irc, $line) = @_; # Remember, we receive pointers to scalars, so we can modify them $$line = 'frobnicate!'; # Return an exit code return PCSI_EAT_NONE; } # Default handler for events that do not have a corresponding # plugin method defined. sub _default { my ($self, $irc, $event) = splice @_, 0, 3; print "Default called for $event\n"; # Return an exit code return PCSI_EAT_NONE; } =head2 Pipeline The plugins are given priority on a first come, first serve basis. Therefore, plugins that were added before others have the first shot at processing events. See L for details. my $pipeline = $ircd->pipeline(); =head1 EVENTS =head2 SERVER hooks Hooks that are targeted toward data received from the server will get the exact same arguments as if it was a normal event, look at the POE::Component::Server::IRC::Backend docs for more information. B Server methods are identified in the plugin namespace by the subroutine prefix of IRCD_*. I.e. an ircd_cmd_kick event handler would be: sub IRCD_cmd_kick {} The only difference is instead of getting scalars, the hook will get a reference to the scalar, to allow it to mangle the data. This allows the plugin to modify data *before* they are sent out to registered sessions. They are required to return one of the exit codes so POE::Component::Server::IRC::Backend will know what to do. Names of potential hooks: socketerr connected plugin_del ... Keep in mind that they are always lowercased, check out the POE::Component::Server::IRC documentation. =head2 C<_default> If a plugin doesn't have a specific hook method defined for an event, the component will attempt to call a plugin's C<_default> method. The first parameter after the plugin and irc objects will be the handler name. sub _default { my ($self, $irc, $event) = splice @_, 0, 3; return PCSI_EAT_NONE; } The C<_default> handler is expected to return one of the exit codes so POE::Component::Server::IRC::Backend will know what to do. =head1 EXPORTS The following constants are exported on demand. =head2 C This means the event will continue to be processed by remaining plugins and finally, sent to interested sessions that registered for it. =head2 C This means the event will continue to be processed by remaining plugins but it will not be sent to any sessions that registered for it. =head2 C This means the event will not be processed by remaining plugins, it will go straight to interested sessions. =head2 C This means the event will be completely discarded, no plugin or session will see it. =head1 SEE ALSO L =cut libpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/Server/IRC/Backend.pm0000644000175000017500000012442612353530642027001 0ustar gregoagregoapackage POE::Component::Server::IRC::Backend; BEGIN { $POE::Component::Server::IRC::Backend::AUTHORITY = 'cpan:HINRIK'; } BEGIN { $POE::Component::Server::IRC::Backend::VERSION = '1.52'; } use strict; use warnings; use Carp qw(croak); use List::Util qw(first); use POE qw(Wheel::SocketFactory Wheel::ReadWrite Filter::Stackable Filter::Line Filter::IRCD); use Net::Netmask; use Socket qw(unpack_sockaddr_in inet_ntoa); use base qw(POE::Component::Syndicator); use constant { OBJECT_STATES_HASHREF => { syndicator_started => '_start', add_connector => '_add_connector', add_listener => '_add_listener', del_listener => '_del_listener', send_output => '_send_output', shutdown => '_shutdown', }, OBJECT_STATES_ARRAYREF => [qw( _accept_connection _accept_failed _conn_alarm _conn_input _conn_error _conn_flushed _event_dispatcher _sock_failed _sock_up )], }; sub create { my $package = shift; croak("$package requires an even number of parameters") if @_ & 1; my %args = @_; $args{ lc $_ } = delete $args{$_} for keys %args; my $self = bless { }, $package; $self->{raw_events} = $args{raw_events} if defined $args{raw_events}; $self->{prefix} = defined $args{prefix} ? $args{prefix} : 'ircd_'; $self->{antiflood} = defined $args{antiflood} ? $args{antiflood} : 1; $self->{auth} = defined $args{auth} ? $args{auth} : 1; if ($args{sslify_options} && ref $args{sslify_options} eq 'ARRAY') { eval { require POE::Component::SSLify; POE::Component::SSLify->import( qw(SSLify_Options Server_SSLify Client_SSLify) ); }; chomp $@; croak("Can't use ssl: $@") if $@; eval { SSLify_Options(@{ $args{sslify_options} }); }; chomp $@; croak("Can't use ssl: $@") if $@; $self->{got_ssl} = 1; } if ($args{states}) { my $error = $self->_validate_states($args{states}); croak($error) if defined $error; } $self->_syndicator_init( prefix => $self->{prefix}, reg_prefix => 'PCSI_', types => [ SERVER => 'IRCD', USER => 'U' ], object_states => [ $self => OBJECT_STATES_HASHREF, $self => OBJECT_STATES_ARRAYREF, ($args{states} ? map { $self => $_ } @{ $args{states} } : () ), ], ($args{plugin_debug} ? (debug => 1) : () ), (ref $args{options} eq 'HASH' ? (options => $args{options}) : ()), ); if ($self->{auth}) { require POE::Component::Server::IRC::Plugin::Auth; $self->plugin_add( 'Auth_'.$self->session_id(), POE::Component::Server::IRC::Plugin::Auth->new(), ); } return $self; } sub _validate_states { my ($self, $states) = @_; for my $events (@$states) { if (ref $events eq 'HASH') { for my $event (keys %$events) { if (OBJECT_STATES_HASHREF->{$event} || first { $event eq $_ } @{ +OBJECT_STATES_ARRAYREF }) { return "Event $event is reserved by ". __PACKAGE__; } } } elsif (ref $events eq 'ARRAY') { for my $event (@$events) { if (OBJECT_STATES_HASHREF->{$event} || first { $event eq $_ } @{ +OBJECT_STATES_ARRAYREF }) { return "Event $event is reserved by ". __PACKAGE__; } } } } return; } sub _start { my ($kernel, $self, $sender) = @_[KERNEL, OBJECT, SENDER]; $self->{ircd_filter} = POE::Filter::IRCD->new( colonify => 1, ); $self->{line_filter} = POE::Filter::Line->new( InputRegexp => '\015?\012', OutputLiteral => "\015\012", ); $self->{filter} = POE::Filter::Stackable->new( Filters => [$self->{line_filter}, $self->{ircd_filter}], ); return; } sub raw_events { my ($self, $value) = @_; $self->{raw_events} = 1 if $value; return; } sub shutdown { my ($self) = shift; $self->yield('shutdown', @_); return; } sub _shutdown { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{terminating} = 1; delete $self->{listeners}; delete $self->{connectors}; delete $self->{wheels}; $self->_syndicator_destroy(); return; } sub _accept_failed { my ($kernel, $self, $operation, $errnum, $errstr, $listener_id) = @_[KERNEL, OBJECT, ARG0..ARG3]; my $port = $self->{listeners}{$listener_id}{port}; my $addr = $self->{listeners}{$listener_id}{addr}; delete $self->{listeners}{$listener_id}; $self->send_event( "$self->{prefix}listener_failure", $listener_id, $operation, $errnum, $errstr, $port, $addr, ); return; } sub _accept_connection { my ($kernel, $self, $socket, $peeraddr, $peerport, $listener_id) = @_[KERNEL, OBJECT, ARG0..ARG3]; my $sockaddr = inet_ntoa((unpack_sockaddr_in(getsockname $socket))[1]); my $sockport = (unpack_sockaddr_in(getsockname $socket))[0]; $peeraddr = inet_ntoa($peeraddr); my $listener = $self->{listeners}{$listener_id}; if ($self->{got_ssl} && $listener->{usessl}) { eval { $socket = POE::Component::SSLify::Server_SSLify($socket); }; chomp $@; die "Failed to SSLify server socket: $@" if $@; } return if $self->denied($peeraddr); my $wheel = POE::Wheel::ReadWrite->new( Handle => $socket, Filter => $self->{filter}, InputEvent => '_conn_input', ErrorEvent => '_conn_error', FlushedEvent => '_conn_flushed', ); if ($wheel) { my $wheel_id = $wheel->ID(); my $ref = { wheel => $wheel, peeraddr => $peeraddr, peerport => $peerport, flooded => 0, sockaddr => $sockaddr, sockport => $sockport, idle => time(), antiflood => $listener->{antiflood}, compress => 0 }; my $needs_auth = $listener->{auth} && $self->{auth} ? 1 : 0; $self->send_event( "$self->{prefix}connection", $wheel_id, $peeraddr, $peerport, $sockaddr, $sockport, $needs_auth, ); $ref->{alarm} = $kernel->delay_set( '_conn_alarm', $listener->{idle}, $wheel_id, ); $self->{wheels}{$wheel_id} = $ref; } return; } sub add_listener { my ($self) = shift; croak('add_listener requires an even number of parameters') if @_ & 1; $self->yield('add_listener', @_); return; } sub _add_listener { my ($kernel, $self) = @_[KERNEL, OBJECT]; my %args = @_[ARG0..$#_]; $args{ lc($_) } = delete $args{$_} for keys %args; my $bindaddr = $args{bindaddr} || '0.0.0.0'; my $bindport = $args{port} || 0; my $idle = $args{idle} || 180; my $auth = 1; my $antiflood = 1; my $usessl = 0; $usessl = 1 if $args{usessl}; $auth = 0 if defined $args{auth} && $args{auth} eq '0'; $antiflood = 0 if defined $args{antiflood} && $args{antiflood} eq '0'; my $listener = POE::Wheel::SocketFactory->new( BindAddress => $bindaddr, BindPort => $bindport, SuccessEvent => '_accept_connection', FailureEvent => '_accept_failed', Reuse => 'on', ($args{listenqueue} ? (ListenQueue => $args{listenqueue}) : ()), ); my $id = $listener->ID(); $self->{listeners}{$id}{wheel} = $listener; $self->{listeners}{$id}{port} = $bindport; $self->{listeners}{$id}{addr} = $bindaddr; $self->{listeners}{$id}{idle} = $idle; $self->{listeners}{$id}{auth} = $auth; $self->{listeners}{$id}{antiflood} = $antiflood; $self->{listeners}{$id}{usessl} = $usessl; my ($port, $addr) = unpack_sockaddr_in($listener->getsockname); if ($port) { $self->{listeners}{$id}{port} = $port; $self->send_event( $self->{prefix} . 'listener_add', $port, $id, $bindaddr, ); } return; } sub del_listener { my ($self) = shift; croak("add_listener requires an even number of parameters") if @_ & 1; $self->yield('del_listener', @_); return; } sub _del_listener { my ($kernel, $self) = @_[KERNEL, OBJECT]; my %args = @_[ARG0..$#_]; $args{lc $_} = delete $args{$_} for keys %args; my $listener_id = delete $args{listener}; my $port = delete $args{port}; if ($self->_listener_exists($listener_id)) { my $port = $self->{listeners}{$listener_id}{port}; my $addr = $self->{listeners}{$listener_id}{addr}; delete $self->{listeners}{$listener_id}; $self->send_event( $self->{prefix} . 'listener_del', $port, $listener_id, $addr, ); } elsif (defined $port) { while (my ($id, $listener) = each %{ $self->{listeners } }) { if ($listener->{port} == $port) { my $addr = $listener->{addr}; delete $self->{listeners}{$id}; $self->send_event( $self->{prefix} . 'listener_del', $port, $listener_id, $addr, ); } } } return; } sub _listener_exists { my $self = shift; my $listener_id = shift || return; return 1 if defined $self->{listeners}{$listener_id}; return; } sub add_connector { my $self = shift; croak("add_connector requires an even number of parameters") if @_ & 1; $self->yield('add_connector', @_); return; } sub _add_connector { my ($kernel, $self, $sender) = @_[KERNEL, OBJECT, SENDER]; my %args = @_[ARG0..$#_]; $args{lc $_} = delete $args{$_} for keys %args; my $remoteaddress = $args{remoteaddress}; my $remoteport = $args{remoteport}; return if !$remoteaddress || !$remoteport; my $wheel = POE::Wheel::SocketFactory->new( SocketProtocol => 'tcp', RemoteAddress => $remoteaddress, RemotePort => $remoteport, SuccessEvent => '_sock_up', FailureEvent => '_sock_failed', ($args{bindaddress} ? (BindAddress => $args{bindaddress}) : ()), ); if ($wheel) { $args{wheel} = $wheel; $self->{connectors}{$wheel->ID()} = \%args; } return; } sub _sock_failed { my ($kernel, $self, $op, $errno, $errstr, $connector_id) = @_[KERNEL, OBJECT, ARG0..ARG3]; my $ref = delete $self->{connectors}{$connector_id}; delete $ref->{wheel}; $self->send_event("$self->{prefix}socketerr", $ref, $op, $errno, $errstr); return; } sub _sock_up { my ($kernel, $self, $socket, $peeraddr, $peerport, $connector_id) = @_[KERNEL, OBJECT, ARG0..ARG3]; $peeraddr = inet_ntoa($peeraddr); my $cntr = delete $self->{connectors}{$connector_id}; if ($self->{got_ssl} && $cntr->{usessl}) { eval { $socket = POE::Component::SSLify::Client_SSLify($socket); }; chomp $@; die "Failed to SSLify client socket: $@" if $@; } my $wheel = POE::Wheel::ReadWrite->new( Handle => $socket, InputEvent => '_conn_input', ErrorEvent => '_conn_error', FlushedEvent => '_conn_flushed', Filter => POE::Filter::Stackable->new( Filters => [$self->{filter}], ), ); return if !$wheel; my $wheel_id = $wheel->ID(); my $sockaddr = inet_ntoa((unpack_sockaddr_in(getsockname $socket))[1]); my $sockport = (unpack_sockaddr_in(getsockname $socket))[0]; my $ref = { wheel => $wheel, peeraddr => $peeraddr, peerport => $peerport, sockaddr => $sockaddr, sockport => $sockport, idle => time(), antiflood => 0, compress => 0, }; $self->{wheels}{$wheel_id} = $ref; $self->send_event( "$self->{prefix}connected", $wheel_id, $peeraddr, $peerport, $sockaddr, $sockport, $cntr->{name} ); return; } sub _anti_flood { my ($self, $wheel_id, $input) = @_; my $current_time = time(); return if !$wheel_id || !$self->connection_exists($wheel_id) || !$input; SWITCH: { if ($self->{wheels}->{ $wheel_id }->{flooded}) { last SWITCH; } if (!$self->{wheels}{$wheel_id}{timer} || $self->{wheels}{$wheel_id}{timer} < $current_time) { $self->{wheels}{$wheel_id}{timer} = $current_time; my $event = "$self->{prefix}cmd_" . lc $input->{command}; $self->send_event($event, $wheel_id, $input); last SWITCH; } if ($self->{wheels}{$wheel_id}{timer} <= $current_time + 10) { $self->{wheels}{$wheel_id}{timer} += 1; push @{ $self->{wheels}{$wheel_id}{msq} }, $input; push @{ $self->{wheels}{$wheel_id}{alarm_ids} }, $poe_kernel->alarm_set( '_event_dispatcher', $self->{wheels}{$wheel_id}{timer}, $wheel_id ); last SWITCH; } $self->{wheels}{$wheel_id}{flooded} = 1; $self->send_event("$self->{prefix}connection_flood", $wheel_id); } return 1; } sub _conn_error { my ($self, $errstr, $wheel_id) = @_[OBJECT, ARG2, ARG3]; return if !$self->connection_exists($wheel_id); $self->_disconnected( $wheel_id, $errstr || $self->{wheels}{$wheel_id}{disconnecting} ); return; } sub _conn_alarm { my ($kernel, $self, $wheel_id) = @_[KERNEL, OBJECT, ARG0]; return if !$self->connection_exists($wheel_id); my $conn = $self->{wheels}{$wheel_id}; $self->send_event( "$self->{prefix}connection_idle", $wheel_id, $conn->{idle}, ); $conn->{alarm} = $kernel->delay_set( '_conn_alar', $conn->{idle}, $wheel_id, ); return; } sub _conn_flushed { my ($kernel, $self, $wheel_id) = @_[KERNEL, OBJECT, ARG0]; return if !$self->connection_exists($wheel_id); if ($self->{wheels}{$wheel_id}{disconnecting}) { $self->_disconnected( $wheel_id, $self->{wheels}{$wheel_id}{disconnecting}, ); return; } if ($self->{wheels}{$wheel_id}{compress_pending}) { delete $self->{wheels}{$wheel_id}{compress_pending}; $self->{wheels}{$wheel_id}{wheel}->get_input_filter()->unshift( POE::Filter::Zlib::Stream->new(), ); $self->send_event("$self->{prefix}compressed_conn", $wheel_id); return; } return; } sub _conn_input { my ($kernel, $self, $input, $wheel_id) = @_[KERNEL, OBJECT, ARG0, ARG1]; my $conn = $self->{wheels}{$wheel_id}; if ($self->{raw_events}) { $self->send_event( "$self->{prefix}raw_input", $wheel_id, $input->{raw_line}, ); } $conn->{seen} = time(); $kernel->delay_adjust($conn->{alarm}, $conn->{idle}); # TODO: Antiflood code if ($self->antiflood($wheel_id)) { $self->_anti_flood($wheel_id, $input); } else { my $event = "$self->{prefix}cmd_" . lc $input->{command}; $self->send_event($event, $wheel_id, $input); } return; } sub _event_dispatcher { my ($kernel, $self, $wheel_id) = @_[KERNEL, OBJECT, ARG0]; if (!$self->connection_exists($wheel_id) || $self->{wheels}{$wheel_id}{flooded}) { return; } shift @{ $self->{wheels}{$wheel_id}{alarm_ids} }; my $input = shift @{ $self->{wheels}{$wheel_id}{msq} }; if ($input) { my $event = "$self->{prefix}cmd_" . lc $input->{command}; $self->send_event($event, $wheel_id, $input); } return; } sub send_output { my ($self, $output) = splice @_, 0, 2; if ($output && ref $output eq 'HASH') { for my $id (grep { $self->connection_exists($_) } @_) { if ($self->{raw_events}) { my $out = $self->{filter}->put([$output])->[0]; $out =~ s/\015\012$//; $self->send_event("$self->{prefix}raw_output", $id, $out); } $self->{wheels}{$id}{wheel}->put($output); } } return; } sub _send_output { $_[OBJECT]->send_output(@_[ARG0..$#_]); return; } sub antiflood { my ($self, $wheel_id, $value) = @_; return if !$self->connection_exists($wheel_id); return 0 if !$self->{antiflood}; return $self->{wheels}{$wheel_id}{antiflood} if !defined $value; if (!$value) { # Flush pending messages from that wheel while (my $alarm_id = shift @{ $self->{wheels}{$wheel_id}{alarm_ids} }) { $poe_kernel->alarm_remove($alarm_id); my $input = shift @{ $self->{wheels}{$wheel_id}{msq} }; if ($input) { my $event = "$self->{prefix}cmd_" . lc $input->{command}; $self->send_event($event, $wheel_id, $input); } } } $self->{wheels}{$wheel_id}{antiflood} = $value; return; } sub compressed_link { my ($self, $wheel_id, $value, $cntr) = @_; return if !$self->connection_exists($wheel_id); return $self->{wheels}{$wheel_id}{compress} if !defined $value; if ($value) { if (!$self->{got_zlib}) { eval { require POE::Filter::Zlib::Stream; $self->{got_zlib} = 1; }; chomp $@; croak($@) if !$self->{got_zlib}; } if ($cntr) { $self->{wheels}{$wheel_id}{wheel}->get_input_filter()->unshift( POE::Filter::Zlib::Stream->new() ); $self->send_event( "$self->{prefix}compressed_conn", $wheel_id, ); } else { $self->{wheels}{$wheel_id}{compress_pending} = 1; } } else { $self->{wheels}{$wheel_id}{wheel}->get_input_filter()->shift(); } $self->{wheels}{$wheel_id}{compress} = $value; return; } sub disconnect { my ($self, $wheel_id, $string) = @_; return if !$wheel_id || !$self->connection_exists($wheel_id); $self->{wheels}{$wheel_id}{disconnecting} = $string || 'Client Quit'; return; } sub _disconnected { my ($self, $wheel_id, $errstr) = @_; return if !$wheel_id || !$self->connection_exists($wheel_id); my $conn = delete $self->{wheels}{$wheel_id}; for my $alarm_id ($conn->{alarm}, @{ $conn->{alarm_ids} }) { $poe_kernel->alarm_remove($_); } $self->send_event( "$self->{prefix}disconnected", $wheel_id, $errstr || 'Client Quit', ); if ( $^O =~ /(cygwin|MSWin)/ ) { $conn->{wheel}->shutdown_input(); $conn->{wheel}->shutdown_output(); } return 1; } sub connection_info { my ($self, $wheel_id) = @_; return if !$self->connection_exists($wheel_id); return map { $self->{wheels}{$wheel_id}{$_} } qw(peeraddr peerport sockaddr sockport); } sub connection_exists { my ($self, $wheel_id) = @_; return if !$wheel_id || !defined $self->{wheels}{$wheel_id}; return 1; } sub _conn_flooded { my $self = shift; my $conn_id = shift || return; return if !$self->connection_exists($conn_id); return $self->{wheels}{$conn_id}{flooded}; } sub add_denial { my $self = shift; my $netmask = shift || return; my $reason = shift || 'Denied'; return if !$netmask->isa('Net::Netmask'); $self->{denials}{$netmask} = { blk => $netmask, reason => $reason, }; return 1; } sub del_denial { my $self = shift; my $netmask = shift || return; return if !$netmask->isa('Net::Netmask'); return if !$self->{denials}{$netmask}; delete $self->{denials}{$netmask}; return 1; } sub add_exemption { my $self = shift; my $netmask = shift || return; return if !$netmask->isa('Net::Netmask'); if (!$self->{exemptions}{$netmask}) { $self->{exemptions}{$netmask} = $netmask; } return 1; } sub del_exemption { my $self = shift; my $netmask = shift || return; return if !$netmask->isa('Net::Netmask'); return if !$self->{exemptions}{$netmask}; delete $self->{exemptions}{$netmask}; return 1; } sub denied { my $self = shift; my $ipaddr = shift || return; return if $self->exempted($ipaddr); for my $mask (keys %{ $self->{denials} }) { if ($self->{denials}{$mask}{blk}->match($ipaddr)) { return $self->{denials}{$mask}{reason}; } } return; } sub exempted { my $self = shift; my $ipaddr = shift || return; for my $mask (keys %{ $self->{exemptions} }) { return 1 if $self->{exemptions}{$mask}->match($ipaddr); } return; } 1; =encoding utf8 =head1 NAME POE::Component::Server::IRC::Backend - A POE component class that provides network connection abstraction for POE::Component::Server::IRC =head1 SYNOPSIS package MyIRCD; use strict; use warnings; use base 'POE::Component::Server::IRC::Backend'; sub spawn { my ($package, %args) = @_; my $self = $package->create(prefix => 'ircd_', @_); # process %args ... return $self; } =head1 DESCRIPTION POE::Component::Server::IRC::Backend - A POE component class that provides network connection abstraction for L. It uses a plugin system. See L for details. =head1 CONSTRUCTOR =head2 C Returns an object. Accepts the following parameters, all are optional: =over 4 =item * B<'alias'>, a POE::Kernel alias to set; =item * B<'auth'>, set to a false value to globally disable IRC authentication, default is auth is enabled; =item * B<'antiflood'>, set to a false value to globally disable flood protection, default is true; =item * B<'prefix'>, this is the prefix that is used to generate event names that the component produces. The default is 'ircd_'. =item * B<'states'>, an array reference of extra objects states for the IRC daemon's POE sessions. The elements can be array references of states as well as hash references of state => handler pairs. =item * B<'plugin_debug'>, set to a true value to print plugin debug info. Default is false. =item * B<'options'>, a hashref of options to L =item * B<'raw_events'>, whether to send L events. False by default. Can be enabled later with L|/raw_events>; =back If the component is created from within another session, that session will be automagcially registered with the component to receive events and get an 'ircd_backend_registered' event. =head1 METHODS =head2 General =head3 C Takes no arguments. Terminates the component. Removes all listeners and connectors. Disconnects all current client and server connections. This is a shorthand for C<< $ircd->yield('shutdown') >>. =head3 C I> Takes no arguments. Returns the ID of the component's session. Ideal for posting events to the component. =head3 C I> Takes no arguments. Returns the session alias that has been set through L|/create>'s B<'alias'> argument. =head3 C I> This method provides an alternative object based means of posting events to the component. First argument is the event to post, following arguments are sent as arguments to the resultant post. =head3 C I> This method provides an alternative object based means of calling events to the component. First argument is the event to call, following arguments are sent as arguments to the resultant call. =head3 C I> This method provides a way of posting delayed events to the component. The first argument is an arrayref consisting of the delayed command to post and any command arguments. The second argument is the time in seconds that one wishes to delay the command being posted. Returns an alarm ID that can be used with L|/delay_remove> to cancel the delayed event. This will be undefined if something went wrong. =head3 C I> This method removes a previously scheduled delayed event from the component. Takes one argument, the C that was returned by a L|/delay> method call. Returns an arrayref that was originally requested to be delayed. =head3 C I> Sends an event through the component's event handling system. These will get processed by plugins then by registered sessions. First argument is the event name, followed by any parameters for that event. =head3 C I> This sends an event right after the one that's currently being processed. Useful if you want to generate some event which is directly related to another event so you want them to appear together. This method can only be called when POE::Component::IRC is processing an event, e.g. from one of your event handlers. Takes the same arguments as L|/send_event>. =head3 C I> This will send an event to be processed immediately. This means that if an event is currently being processed and there are plugins or sessions which will receive it after you do, then an event sent with C will be received by those plugins/sessions I the current event. Takes the same arguments as L|/send_event>. =head3 C If called with a true value, raw events (L|/ircd_raw_input> and L|/ircd_raw_output>) will be enabled. =head2 Connections =head3 C Takes two arguments, a connection id and true/false value. If value is specified antiflood protection is enabled or disabled accordingly for the specified connection. If a value is not specified the current status of antiflood protection is returned. Returns undef on error. =head3 C Takes two arguments, a connection id and true/false value. If a value is specified, compression will be enabled or disabled accordingly for the specified connection. If a value is not specified the current status of compression is returned. Returns undef on error. =head3 C Requires on argument, the connection id you wish to disconnect. The component will terminate the connection the next time that the wheel input is flushed, so you may send some sort of error message to the client on that connection. Returns true on success, undef on error. =head3 C Requires one argument, a connection id. Returns true value if the connection exists, false otherwise. =head3 C Takes one argument, a connection_id. Returns a list consisting of: the IP address of the peer; the port on the peer; our socket address; our socket port. Returns undef on error. my ($peeraddr, $peerport, $sockaddr, $sockport) = $ircd->connection_info($conn_id); =head3 C Takes one mandatory argument and one optional. The first mandatory argument is a L object that will be used to check connecting IP addresses against. The second optional argument is a reason string for the denial. =head3 C Takes one mandatory argument, a L object to remove from the current denial list. =head3 C Takes one argument, an IP address. Returns true or false depending on whether that IP is denied or not. =head3 C Takes one mandatory argument, a L object that will be checked against connecting IP addresses for exemption from denials. =head3 C Takes one mandatory argument, a L object to remove from the current exemption list. =head3 C Takes one argument, an IP address. Returns true or false depending on whether that IP is exempt from denial or not. =head2 Plugins =head3 C I> Returns the L object. =head3 C I> Accepts two arguments: The alias for the plugin The actual plugin object Any number of extra arguments The alias is there for the user to refer to it, as it is possible to have multiple plugins of the same kind active in one Object::Pluggable object. This method goes through the pipeline's C method, which will call C<< $plugin->plugin_register($pluggable, @args) >>. Returns the number of plugins now in the pipeline if plugin was initialized, C/an empty list if not. =head3 C I> Accepts the following arguments: The alias for the plugin or the plugin object itself Any number of extra arguments This method goes through the pipeline's C method, which will call C<< $plugin->plugin_unregister($pluggable, @args) >>. Returns the plugin object if the plugin was removed, C/an empty list if not. =head3 C I> Accepts the following arguments: The alias for the plugin This method goes through the pipeline's C method. Returns the plugin object if it was found, C/an empty list if not. =head3 C I> Takes no arguments. Returns a hashref of plugin objects, keyed on alias, or an empty list if there are no plugins loaded. =head3 C I> Takes no arguments. Returns an arrayref of plugin objects, in the order which they are encountered in the pipeline. =head3 C I> Accepts the following arguments: The plugin object The type of the hook (the hook types are specified with _pluggable_init()'s 'types') The event name[s] to watch The event names can be as many as possible, or an arrayref. They correspond to the prefixed events and naturally, arbitrary events too. You do not need to supply events with the prefix in front of them, just the names. It is possible to register for all events by specifying 'all' as an event. Returns 1 if everything checked out fine, C/an empty list if something is seriously wrong. =head3 C I> Accepts the following arguments: The plugin object The type of the hook (the hook types are specified with _pluggable_init()'s 'types') The event name[s] to unwatch The event names can be as many as possible, or an arrayref. They correspond to the prefixed events and naturally, arbitrary events too. You do not need to supply events with the prefix in front of them, just the names. It is possible to register for all events by specifying 'all' as an event. Returns 1 if all the event name[s] was unregistered, undef if some was not found. =head1 INPUT EVENTS These are POE events that the component will accept: =head2 C I> Takes N arguments: a list of event names that your session wants to listen for, minus the C prefix. $ircd->yield('register', qw(connected disconnected)); The special argument 'all' will register your session for all events. Registering will generate an L|/ircd_registered> event that your session can trap. =head2 C I> Takes N arguments: a list of event names which you I want to receive. If you've previously done a L|/register> for a particular event which you no longer care about, this event will tell the component to stop sending them to you. (If you haven't, it just ignores you. No big deal.) If you have registered with 'all', attempting to unregister individual events such as 'connected', etc. will not work. This is a 'feature'. =head2 C Takes a number of arguments. Adds a new listener. =over 4 =item * B<'port'>, the TCP port to listen on. Default is a random port; =item * B<'auth'>, enable or disable auth sub-system for this listener. Enabled by default; =item * B<'bindaddr'>, specify a local address to bind the listener to; =item * B<'listenqueue'>, change the SocketFactory's ListenQueue; =item * B<'usessl'>, whether the listener should use SSL. Default is false; =item * B<'antiflood'>, whether the listener should use flood protection. Defaults is true; =item * B<'idle'>, the time, in seconds, after which a connection will be considered idle. Defaults is 180. =back =head2 C Takes one of the following arguments: =over 4 =item * B<'listener'>, a previously returned listener ID; =item * B<'port'>, a listening port; =back The listener will be deleted. Note: any connected clients on that port will not be disconnected. =head2 C Takes two mandatory arguments, B<'remoteaddress'> and B<'remoteport'>. Opens a TCP connection to specified address and port. =over 4 =item * B<'remoteaddress'>, hostname or IP address to connect to; =item * B<'remoteport'>, the TCP port on the remote host; =item * B<'bindaddress'>, a local address to bind from (optional); =back =head2 C Takes a hashref and one or more connection IDs. $ircd->yield( 'send_output', { prefix => 'blah!~blah@blah.blah.blah', command => 'PRIVMSG', params => ['#moo', 'cows go moo, not fish :D'] }, @list_of_connection_ids, ); =head2 C I> Takes no arguments. Terminates the component. Removes all listeners and connectors. Disconnects all current client and server connections. =head1 OUTPUT EVENTS These following events are sent to interested sessions. =head2 C I> =over =item Emitted: when a session registers with the component; =item Target: the registering session; =item Args: =over 4 =item * C: the component's object; =back =back =head2 C =over =item Emitted: when a client connects to one of the component's listeners; =item Target: all plugins and registered sessions =item Args: =over 4 =item * C: the conn id; =item * C: their ip address; =item * C: their tcp port; =item * C: our ip address; =item * C: our socket port; =item * C: a boolean indicating whether the client needs to be authed =back =back =head2 C =over =item Emitted: after a client has connected and the component has validated hostname and ident; =item Target: Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, a HASHREF with the following keys: 'ident' and 'hostname'; =back =back =head2 C =over =item Emitted: on a successful L|/add_listener> call; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the listening port; =item * C, the listener id; =item * C, the listening address; =back =back =head2 C =over =item Emitted: on a successful L|/del_listener> call; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the listening port; =item * C, the listener id; =item * C, the listener address; =back =back =head2 C =over =item Emitted: when a listener wheel fails; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the listener id; =item * C, the name of the operation that failed; =item * C, numeric value for $!; =item * C, string value for $!; =item * C, the port it tried to listen on; =item * C, the address it tried to listen on; =back =back =head2 C =over =item Emitted: on the failure of an L|/add_connector> call =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, a HASHREF containing the params that add_connector() was called with; =item * C, the name of the operation that failed; =item * C, numeric value for $!; =item * C, string value for $!; =back =back =head2 C =over =item Emitted: when the component establishes a connection with a peer; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, their ip address; =item * C, their tcp port; =item * C, our ip address; =item * C, our socket port; =item * C, the peer's name; =back =back =head2 C =over =item Emitted: when a client connection is flooded; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =back =back =head2 C =over =item Emitted: when a client connection has not sent any data for a set period; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, the number of seconds period we consider as idle; =back =back =head2 C =over =item Emitted: when compression has been enabled for a connection =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =back =back =head2 C =over =item Emitted: when a client or peer sends a valid IRC line to us; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, a HASHREF containing the output record from POE::Filter::IRCD: { prefix => 'blah!~blah@blah.blah.blah', command => 'PRIVMSG', params => [ '#moo', 'cows go moo, not fish :D' ], raw_line => ':blah!~blah@blah.blah.blah.blah PRIVMSG #moo :cows go moo, not fish :D' } =back =back =head2 C =over =item Emitted: when a line of input is received from a connection =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, the raw line of input =back =back =head2 C =over =item Emitted: when a line of output is sent over a connection =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, the raw line of output =back =back =head2 C =over =item Emitted: when a client disconnects; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, the error or reason for disconnection; =back =back =head2 C I> =over =item Emitted: when the component has been asked to L|/shutdown> =item Target: all registered sessions; =item Args: =over 4 =item * C: the session ID of the requesting component =back =back =head2 C I> =over =item Emitted: on a successful addition of a delayed event using the L|/delay> method =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C: the alarm id which can be used later with L|/delay_remove> =item * C: subsequent arguments are those which were passed to L|/delay> =back =back =head2 C I> =over =item Emitted: when a delayed command is successfully removed =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C: the alarm id which was removed =item * C: subsequent arguments are those which were passed to L|/delay> =back =back =head2 C I> =over =item Emitted: when a new plugin is added to the pipeline =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C: the plugin alias =item * C: the plugin object =back =back =head2 C I> =over =item Emitted: when a plugin is removed from the pipeline =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C: the plugin alias =item * C: the plugin object =back =back =head2 C I> =over =item Emitted: when an error occurs while executing a plugin handler =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C: the error message =item * C: the plugin alias =item * C: the plugin object =back =back =head1 AUTHOR Chris 'BinGOs' Williams =head1 LICENSE Copyright E Chris Williams This module may be used, modified, and distributed under the same terms as Perl itself. Please see the license that came with your Perl distribution for details. =head1 SEE ALSO L L L =cut libpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/Server/IRC.pm0000644000175000017500000105562612353530642025460 0ustar gregoagregoapackage POE::Component::Server::IRC; BEGIN { $POE::Component::Server::IRC::AUTHORITY = 'cpan:HINRIK'; } BEGIN { $POE::Component::Server::IRC::VERSION = '1.52'; } use strict; use warnings; use Carp qw(croak); use IRC::Utils qw(uc_irc parse_mode_line unparse_mode_line normalize_mask matches_mask gen_mode_change is_valid_nick_name is_valid_chan_name); use List::Util qw(sum); use POE; use POE::Component::Server::IRC::Common qw(chkpasswd); use POE::Component::Server::IRC::Plugin qw(:ALL); use POSIX 'strftime'; use base qw(POE::Component::Server::IRC::Backend); sub spawn { my ($package, %args) = @_; $args{lc $_} = delete $args{$_} for keys %args; my $config = delete $args{config}; my $debug = delete $args{debug}; my $self = $package->create( ($debug ? (raw_events => 1) : ()), %args, states => [ [qw(add_spoofed_nick del_spoofed_nick)], { map { +"daemon_cmd_$_" => '_spoofed_command' } qw(join part mode kick topic nick privmsg notice gline kline unkline sjoin locops wallops operwall) }, ], ); $self->configure($config ? $config : ()); $self->{debug} = $debug; $self->_state_create(); return $self; } sub IRCD_connection { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id, $peeraddr, $peerport, $sockaddr, $sockport, $needs_auth) = map { ${ $_ } } @_; if ($self->_connection_exists($conn_id)) { delete $self->{state}{conns}{$conn_id}; } $self->{state}{conns}{$conn_id}{registered} = 0; $self->{state}{conns}{$conn_id}{type} = 'u'; $self->{state}{conns}{$conn_id}{seen} = time(); $self->{state}{conns}{$conn_id}{socket} = [$peeraddr, $peerport, $sockaddr, $sockport]; $self->_state_conn_stats(); if (!$needs_auth) { $self->{state}{conns}{$conn_id}{auth} = { hostname => '', ident => '', }; $self->_client_register($conn_id); } return PCSI_EAT_CLIENT; } sub IRCD_connected { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id, $peeraddr, $peerport, $sockaddr, $sockport, $name) = map { ${ $_ } } @_; if ($self->_connection_exists($conn_id)) { delete $self->{state}{conns}{$conn_id}; } $self->{state}{conns}{$conn_id}{peer} = $name; $self->{state}{conns}{$conn_id}{registered} = 0; $self->{state}{conns}{$conn_id}{cntr} = 1; $self->{state}{conns}{$conn_id}{type} = 'u'; $self->{state}{conns}{$conn_id}{seen} = time(); $self->{state}{conns}{$conn_id}{socket} = [$peeraddr, $peerport, $sockaddr, $sockport]; $self->_state_conn_stats(); $self->_state_send_credentials($conn_id, $name); return PCSI_EAT_CLIENT; } sub IRCD_connection_flood { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id) = map { ${ $_ } } @_; $self->_terminate_conn_error($conn_id, 'Excess Flood'); return PCSI_EAT_CLIENT; } sub IRCD_connection_idle { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id, $interval) = map { ${ $_ } } @_; return PCSI_EAT_NONE if !$self->_connection_exists($conn_id); my $conn = $self->{state}{conns}{$conn_id}; if ($conn->{type} eq 'u') { $self->_terminate_conn_error($conn_id, 'Connection Timeout'); return PCSI_EAT_CLIENT; } if ($conn->{pinged}) { my $msg = 'Ping timeout: '.(time - $conn->{seen}).' seconds'; $self->_terminate_conn_error($conn_id, $msg); return PCSI_EAT_CLIENT; } $conn->{pinged} = 1; $self->send_output( { command => 'PING', params => [$self->server_name()], }, $conn_id, ); return PCSI_EAT_CLIENT; } sub IRCD_auth_done { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id, $ref) = map { ${ $_ } } @_; return PCSI_EAT_CLIENT if !$self->_connection_exists($conn_id); $self->{state}{conns}{$conn_id}{auth} = $ref; $self->_client_register($conn_id); return PCSI_EAT_CLIENT; } sub IRCD_disconnected { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id, $errstr) = map { ${ $_ } } @_; return PCSI_EAT_CLIENT if !$self->_connection_exists($conn_id); if ($self->_connection_is_peer($conn_id)) { my $peer = $self->{state}{conns}{$conn_id}{name}; $self->send_output( @{ $self->_daemon_peer_squit($conn_id, $peer, $errstr) } ); } elsif ($self->_connection_is_client($conn_id)) { $self->send_output( @{ $self->_daemon_cmd_quit( $self->_client_nickname($conn_id,$errstr ), $errstr, )} ); } delete $self->{state}{conns}{$conn_id}; return PCSI_EAT_CLIENT; } sub IRCD_compressed_conn { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id) = map { ${ $_ } } @_; $self->_state_send_burst($conn_id); return PCSI_EAT_CLIENT; } sub IRCD_raw_input { my ($self, $ircd) = splice @_, 0, 2; return PCSI_EAT_CLIENT if !$self->{debug}; my $conn_id = ${ $_[0] }; my $input = ${ $_[1] }; warn "<<< $conn_id: $input\n"; return PCSI_EAT_CLIENT; } sub IRCD_raw_output { my ($self, $ircd) = splice @_, 0, 2; return PCSI_EAT_CLIENT if !$self->{debug}; my $conn_id = ${ $_[0] }; my $output = ${ $_[1] }; warn ">>> $conn_id: $output\n"; return PCSI_EAT_CLIENT; } sub _default { my ($self, $ircd, $event) = splice @_, 0, 3; return PCSI_EAT_NONE if $event !~ /^IRCD_cmd_/; pop @_; my ($conn_id, $input) = map { $$_ } @_; return PCSI_EAT_CLIENT if !$self->_connection_exists($conn_id); $self->{state}{conns}{$conn_id}{seen} = time; if (!$self->_connection_registered($conn_id)) { $self->_cmd_from_unknown($conn_id, $input); } elsif ($self->_connection_is_peer($conn_id)) { $self->_cmd_from_peer($conn_id, $input); } elsif ($self->_connection_is_client($conn_id)) { delete $input->{prefix}; $self->_cmd_from_client($conn_id, $input); } return PCSI_EAT_CLIENT; } sub _auth_finished { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); return $self->{state}{conns}{$conn_id}{auth}; } sub _connection_exists { my $self = shift; my $conn_id = shift || return; return if !defined $self->{state}{conns}{$conn_id}; return 1; } sub _client_register { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); return if !$self->{state}{conns}{$conn_id}{nick}; return if !$self->{state}{conns}{$conn_id}{user}; my $auth = $self->_auth_finished($conn_id); return if !$auth; # pass required for link if (!$self->_state_auth_client_conn($conn_id)) { $self->_terminate_conn_error( $conn_id, 'You are not authorized to use this server', ); return; } if ($self->_state_user_matches_gline($conn_id)) { $self->_terminate_conn_error($conn_id, 'G-Lined'); return; } if ($self->_state_user_matches_kline($conn_id)) { $self->_terminate_conn_error($conn_id, 'K-Lined'); return; } if ($self->_state_user_matches_rkline($conn_id)) { $self->_terminate_conn_error($conn_id, 'K-Lined'); return; } # Add new nick $self->_state_register_client($conn_id); my $server = $self->server_name(); my $nick = $self->_client_nickname($conn_id); my $port = $self->{state}{conns}{$conn_id}{socket}[3]; my $version = $self->server_version(); my $network = $self->server_config('NETWORK'); my $server_is = "$server\[$server/$port]"; $self->_send_output_to_client( $conn_id, { prefix => $server, command => '001', params => [ $nick, "Welcome to the $network Internet Relay Chat network $nick" ], } ); $self->_send_output_to_client( $conn_id, { prefix => $server, command => '002', params => [ $nick, "Your host is $server_is, running version $version", ], }, ); $self->_send_output_to_client( $conn_id, { prefix => $server, command => '003', params => [$nick, $self->server_created()], }, ); $self->_send_output_to_client( $conn_id, { prefix => $server, command => '004', colonify => 0, params => [ $nick, $server, $version, 'Dilowz', 'biklmnopstveIh', 'bkloveIh', ], } ); for my $output (@{ $self->_daemon_cmd_isupport($nick) }) { $self->_send_output_to_client($conn_id, $output); } $self->{state}{conns}{$conn_id}{registered} = 1; $self->{state}{conns}{$conn_id}{type} = 'c'; $self->send_event( 'cmd_lusers', $conn_id, { command => 'LUSERS' }, ); $self->send_event( 'cmd_motd', $conn_id, { command => 'MOTD' }, ); $self->send_event( 'cmd_mode', $conn_id, { command => 'MODE', params => [$nick, '+i'], }, ); return 1; } sub _connection_registered { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); return $self->{state}{conns}{$conn_id}{registered}; } sub _connection_is_peer { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); return if !$self->{state}{conns}{$conn_id}{registered}; return 1 if $self->{state}{conns}{$conn_id}{type} eq 'p'; return; } sub _connection_is_client { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); return if !$self->{state}{conns}{$conn_id}{registered}; return 1 if $self->{state}{conns}{$conn_id}{type} eq 'c'; return; } sub _cmd_from_unknown { my ($self, $wheel_id, $input) = @_; my $cmd = uc $input->{command}; my $params = $input->{params} || [ ]; my $pcount = @$params; my $invalid = 0; SWITCH: { if ($cmd eq 'ERROR') { my $peer = $self->{state}{conns}{$wheel_id}{peer}; if (defined $peer) { $self->send_event_next( 'daemon_error', $wheel_id, $peer, $params->[0], ); } } if ($cmd eq 'QUIT') { $self->_terminate_conn_error($wheel_id, 'Client Quit'); last SWITCH; } # PASS or NICK cmd but no parameters. if ($cmd =~ /^(PASS|NICK|SERVER)$/ && !$pcount) { $self->_send_output_to_client($wheel_id, '461', $cmd); last SWITCH; } # PASS or NICK cmd with one parameter, connection from client if ($cmd eq 'PASS' && $pcount) { $self->{state}{conns}{$wheel_id}{lc $cmd} = $params->[0]; if ($params->[1] && $params->[1] =~ /TS$/) { $self->{state}{conns}{$wheel_id}{ts_server} = 1; $self->antiflood($wheel_id, 0); } last SWITCH; } # SERVER stuff. if ($cmd eq 'CAPAB' && $pcount) { $self->{state}{conns}{$wheel_id}{capab} = [split /\s+/, $params->[0]]; last SWITCH; } if ($cmd eq 'SERVER' && $pcount < 2) { $self->_send_output_to_client($wheel_id, '461', $cmd); last SWITCH; } if ($cmd eq 'SERVER') { my $conn = $self->{state}{conns}{$wheel_id}; $conn->{name} = $params->[0]; $conn->{hops} = $params->[1] || 1; $conn->{desc} = $params->[2] || ''; if (!$conn->{ts_server}) { $self->_terminate_conn_error($wheel_id, 'Non-TS server.'); last SWITCH; } if (!$self->_state_auth_peer_conn($wheel_id, $conn->{name}, $conn->{pass})) { $self->_terminate_conn_error( $wheel_id, 'Unauthorised server.', ); last SWITCH; } if ($self->state_peer_exists($conn->{name})) { $self->_terminate_conn_error($wheel_id, 'Server exists.'); last SWITCH; } $self->_state_register_peer($wheel_id); if ($conn->{zip} && grep { $_ eq 'ZIP' } @{ $conn->{capab} }) { $self->compressed_link($wheel_id, 1, $conn->{cntr}); } else { $self->_state_send_burst($wheel_id); } $self->send_event( "daemon_capab", $conn->{name}, @{ $conn->{capab} }, ); last SWITCH; } if ($cmd eq 'NICK' && $pcount) { if (!is_valid_nick_name($params->[0])) { $self->_send_output_to_client( $wheel_id, '432', $params->[0], ); last SWITCH; } if ($self->state_nick_exists($params->[0])) { $self->_send_output_to_client( $wheel_id, '433', $params->[0], ); last SWITCH; } my $nicklen = $self->server_config('NICKLEN'); if (length($params->[0]) > $nicklen) { $params->[0] = substr($params->[0], 0, $nicklen); } $self->{state}{conns}{$wheel_id}{lc $cmd} = $params->[0]; $self->{state}{pending}{uc_irc($params->[0])} = $wheel_id; $self->_client_register($wheel_id); last SWITCH; } if ($cmd eq 'USER' && $pcount < 4) { $self->_send_output_to_client($wheel_id, '461', $cmd); last SWITCH; } if ($cmd eq 'USER') { $self->{state}{conns}{$wheel_id}{user} = $params->[0]; $self->{state}{conns}{$wheel_id}{ircname} = $params->[3] || ''; $self->_client_register($wheel_id); last SWITCH; } last SWITCH if $self->{state}{conns}{$wheel_id}{cntr}; $invalid = 1; $self->_send_output_to_client($wheel_id, '451'); } return 1 if $invalid; $self->_state_cmd_stat($cmd, $input->{raw_line}); return 1; } sub _cmd_from_peer { my ($self, $conn_id, $input) = @_; my $cmd = $input->{command}; my $params = $input->{params}; my $prefix = $input->{prefix}; my $invalid = 0; SWITCH: { my $method = '_daemon_peer_' . lc $cmd; if ($cmd eq 'SQUIT' && !$prefix ){ $self->_daemon_peer_squit($conn_id, @$params); #$self->_send_output_to_client( # $conn_id, # $prefix, # (ref $_ eq 'ARRAY' ? @{ $_ } : $_) #) for $self->_daemon_cmd_squit($prefix, @$params); last SWITCH; } if ($cmd =~ /\d{3}/) { $self->send_output( $input, $self->_state_user_route($params->[0]) ); last SWITCH; } if ($cmd eq 'QUIT') { $self->send_output( @{ $self->_daemon_peer_quit( $prefix, @$params, $conn_id )} ); last SWITCH; } if ($cmd =~ /^(PRIVMSG|NOTICE)$/) { $self->_send_output_to_client( $conn_id, $prefix, (ref $_ eq 'ARRAY' ? @{ $_ } : $_) ) for $self->_daemon_peer_message( $conn_id, $prefix, $cmd, @$params ); last SWITCH; } if ($cmd =~ /^(WHOIS|VERSION|TIME|NAMES|LINKS|ADMIN|INFO|MOTD|SQUIT)$/i ) { my $client_method = '_daemon_cmd_' . lc $cmd; $self->_send_output_to_client( $conn_id, $prefix, (ref $_ eq 'ARRAY' ? @{ $_ } : $_ ) ) for $self->$client_method($prefix, @$params); last SWITCH; } if ($cmd =~ /^(PING|PONG)$/i && $self->can($method)) { $self->$method($conn_id, @{ $params }); last SWITCH; } if ($cmd =~ /^SVINFO$/i && $self->can($method)) { $self->$method($conn_id, @$params); my $conn = $self->{state}{conns}{$conn_id}; $self->send_event( "daemon_svinfo", $conn->{name}, @$params, ); last SWITCH; } if ($cmd eq 'MODE' && $self->state_nick_exists($params->[0])) { $method = '_daemon_peer_umode'; } if ($self->can($method)) { $self->$method($conn_id, $prefix, @$params); last SWITCH; } $invalid = 1; } return 1 if $invalid; $self->_state_cmd_stat($cmd, $input->{raw_line}, 1); return 1; } sub _cmd_from_client { my ($self, $wheel_id, $input) = @_; my $cmd = uc $input->{command}; my $params = $input->{params} || [ ]; my $pcount = @$params; my $server = $self->server_name(); my $nick = $self->_client_nickname($wheel_id); my $invalid = 0; SWITCH: { my $method = '_daemon_cmd_' . lc $cmd; if ($cmd eq 'QUIT') { $self->_terminate_conn_error( $wheel_id, ($pcount ? qq{"$params->[0]"} : 'Client Quit'), ); last SWITCH; } if ($cmd =~ /^(USERHOST|MODE)$/ && !$pcount) { $self->_send_output_to_client($wheel_id, '461', $cmd); last SWITCH; } if ($cmd =~ /^(USERHOST)$/) { $self->_send_output_to_client($wheel_id, $_) for $self->$method( $nick, ($pcount <= 5 ? @$params : @{ $params }[0..5] ) ); last SWITCH; } if ($cmd =~ /^(PRIVMSG|NOTICE)$/) { $self->{state}{conns}{$wheel_id}{idle_time} = time; $self->_send_output_to_client( $wheel_id, (ref $_ eq 'ARRAY' ? @{ $_ } : $_), ) for $self->_daemon_cmd_message($nick, $cmd, @$params); last SWITCH; } if ($cmd eq 'MODE' && $self->state_nick_exists($params->[0])) { if (uc_irc($nick) ne uc_irc($params->[0])) { $self->_send_output_to_client($wheel_id => '502'); last SWITCH; } my $modestring = join('', @{ $params }[1..$#{ $params }]); $modestring =~ s/\s+//g; $modestring =~ s/[^a-zA-Z+-]+//g; $modestring =~ s/[^DGglwiozl+-]+//g; $modestring = unparse_mode_line($modestring); $self->_send_output_to_client($wheel_id, $_) for $self->_daemon_cmd_umode($nick, $modestring); last SWITCH; } if ($self->can($method)) { $self->_send_output_to_client( $wheel_id, (ref $_ eq 'ARRAY' ? @{ $_ } : $_), ) for $self->$method($nick, @$params); last SWITCH; } $invalid = 1; $self->_send_output_to_client($wheel_id, '421', $cmd); } return 1 if $invalid; $self->_state_cmd_stat($cmd, $input->{raw_line}); return 1; } sub _daemon_cmd_message { my $self = shift; my $nick = shift || return; my $type = shift || return; my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$count) { push @$ref, ['461', $type]; last SWITCH; } if ($count < 2 || !$args->[1]) { push @$ref, ['412']; last SWITCH; } my $targets = 0; my $max_targets = $self->server_config('MAXTARGETS'); my $full = $self->state_user_full($nick); my $targs = $self->_state_parse_msg_targets($args->[0]); LOOP: for my $target (keys %$targs) { my $targ_type = shift @{ $targs->{$target} }; if ($targ_type =~ /(server|host)mask/ && !$self->state_user_is_operator($nick)) { push @$ref, ['481']; next LOOP; } if ($targ_type =~ /(server|host)mask/ && $targs->{$target}[0] !~ /\./) { push @$ref, ['413', $target]; next LOOP; } if ($targ_type =~ /(server|host)mask/ && $targs->{$target}[0] =~ /\x2E.*[\x2A\x3F]+.*$/) { push @$ref, ['414', $target]; next LOOP; } if ($targ_type eq 'channel_ext' && !$self->state_chan_exists($targs->{$target}[1])) { push @$ref, ['401', $targs->{$target}[1]]; next LOOP; } if ($targ_type eq 'channel' && !$self->state_chan_exists($target)) { push @$ref, ['401', $target]; next LOOP; } if ($targ_type eq 'nick' && !$self->state_nick_exists($target)) { push @$ref, ['401', $target]; next LOOP; } if ($targ_type eq 'nick_ext' && !$self->state_peer_exists($targs->{$target}[1])) { push @$ref, ['402', $targs->{$target}[1]]; next LOOP; } $targets++; if ($targets > $max_targets) { push @$ref, ['407', $target]; last SWITCH; } # $$whatever if ($targ_type eq 'servermask') { my $us = 0; my %targets; my $ucserver = uc $self->server_name(); for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask( $targs->{$target}[0], $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{ $self->_state_peer_route($peer) }++; } } } $self->send_output( { prefix => $nick, command => $type, params => [$target, $args->[1]], }, keys %targets, ); if ($us) { my $local = $self->{state}{peers}{uc $self->server_name()}{users}; my @local; my $spoofed = 0; for my $luser (values %$local) { if ($luser->{route_id} eq 'spoofed') { $spoofed = 1; } else { push @local, $luser->{route_id}; } } $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, @local, ); $self->send_event( "daemon_" . lc $type, $full, $target, $args->[1], ) if $spoofed; } next LOOP; } # $#whatever if ($targ_type eq 'hostmask') { my $spoofed = 0; my %targets; my @local; HOST: for my $luser (values %{ $self->{state}{users} }) { if (!matches_mask($targs->{$target}[0], $luser->{auth}{hostname})) {; next HOST; } if ($luser->{route_id} eq 'spoofed') { $spoofed = 1; } elsif ($luser->{type} eq 'r') { $targets{ $luser->{route_id} }++; } else { push @local, $luser->{route_id}; } } $self->send_output( { prefix => $nick, command => $type, params => [$target, $args->[1]], }, keys %targets, ); $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, @local, ); $self->send_event( "daemon_" . lc $type, $full, $target, $args->[1], ) if $spoofed; next LOOP; } if ($targ_type eq 'nick_ext') { $targs->{$target}[1] = $self->_state_peer_name( $targs->{$target}[1]); if ($targs->{$target}[2] && !$self->state_user_is_operator($nick)) { push @$ref, ['481']; next LOOP; } if ($targs->{$target}[1] ne $self->server_name()) { $self->send_output( { prefix => $nick, command => $type, params => [$target, $args->[1]], }, $self->_state_peer_route($targs->{$target}[1]), ); next LOOP; } if (uc $targs->{$target}[0] eq 'OPERS') { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; next LOOP; } $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, keys %{ $self->{state}{localops} }, ); next LOOP; } my @local = $self->_state_find_user_host( $targs->{$target}[0], $targs->{$target}[2], ); if (@local == 1) { my $ref = shift @local; if ($ref->[0] eq 'spoofed') { $self->send_event( "daemon_" . lc $type, $full, $ref->[1], $args->[1], ); } else { $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, $ref->[0], ); } } else { push @$ref, ['407', $target]; next LOOP; } } my ($channel, $status_msg); if ($targ_type eq 'channel') { $channel = $self->_state_chan_name($target); } if ($targ_type eq 'channel_ext') { $channel = $self->_state_chan_name($targs->{target}[1]); $status_msg = $targs->{target}[0]; } if ($channel && $status_msg && !$self->state_user_chan_mode($nick, $channel)) { push @$ref, ['482', $target]; next LOOP; } if ($channel && $self->state_chan_mode_set($channel, 'n') && !$self->state_is_chan_member($nick, $channel)) { push @$ref, ['404', $channel]; next LOOP; } if ($channel && $self->state_chan_mode_set($channel, 'm') && !$self->state_user_chan_mode($nick, $channel)) { push @$ref, ['404', $channel]; next LOOP; } if ($channel && $self->_state_user_banned($nick, $channel) && !$self->state_user_chan_mode($nick, $channel)) { push @$ref, ['404', $channel]; next LOOP; } if ($channel) { my $common = { }; my $msg = { command => $type, params => [ ($status_msg ? $target : $channel), $args->[1] ], }; for my $member ($self->state_chan_list($channel, $status_msg)) { next if $self->_state_user_is_deaf($member); $common->{ $self->_state_user_route($member) }++; } delete $common->{ $self->_state_user_route($nick) }; for my $route_id (keys %$common) { $msg->{prefix} = $nick; if ($self->_connection_is_client($route_id)) { $msg->{prefix} = $full; } if ($route_id ne 'spoofed') { $self->send_output($msg, $route_id); } else { my $tmsg = $type eq 'PRIVMSG' ? 'public' : 'notice'; $self->send_event( "daemon_$tmsg", $full, $channel, $args->[1], ); } } next LOOP; } my $server = $self->server_name(); if ($self->state_nick_exists($target)) { $target = $self->state_user_nick($target); if (my $away = $self->_state_user_away_msg($target)) { push @$ref, { prefix => $server, command => '301', params => [$nick, $target, $away], }; } my $targ_umode = $self->state_user_umode($target); # Target user has CALLERID on if ($targ_umode && $targ_umode =~ /[Gg]/) { my $targ_rec = $self->{state}{users}{uc_irc($target)}; if (($targ_umode =~ /G/ && (!$self->state_users_share_chan($target, $nick) || !$targ_rec->{accepts}{uc_irc($nick)})) || ($targ_umode =~ /g/ && !$targ_rec->{accepts}{uc_irc($nick)})) { push @$ref, { prefix => $server, command => '716', params => [ $nick, $target, 'is in +g mode (server side ignore)', ], }; if (!$targ_rec->{last_caller} || time() - $targ_rec->{last_caller} >= 60) { my ($n, $uh) = split /!/, $self->state_user_full($nick); $self->send_output( { prefix => $server, command => '718', params => [ $target, "$n\[$uh\]", 'is messaging you, and you are umode +g.', ] }, $targ_rec->{route_id}, ) if $targ_rec->{route_id} ne 'spoofed'; push @$ref, { prefix => $server, command => '717', params => [ $nick, $target, 'has been informed that you messaged them.', ], }; } $targ_rec->{last_caller} = time(); next LOOP; } } my $msg = { prefix => $nick, command => $type, params => [$target, $args->[1]], }; my $route_id = $self->_state_user_route($target); if ($route_id eq 'spoofed') { $msg->{prefix} = $full; $self->send_event( "daemon_" . lc $type, $full, $target, $args->[1], ); } else { if ($self->_connection_is_client($route_id)) { $msg->{prefix} = $full; } $self->send_output($msg, $route_id); } next LOOP; } } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_accept { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count || !$args->[0] || $args->[0] eq '*') { my $record = $self->{state}{users}{uc_irc($nick)}; my @list; for my $accept (keys %{ $record->{accepts} }) { if (!$self->state_nick_exists($accept)) { delete $record->{accepts}{$accept}; next; } push @list, $self->state_user_nick($accept); } push @$ref, { prefix => $server, command => '281', params => [$nick, join( ' ', @list)], } if @list; push @$ref, { prefix => $server, command => '282', params => [$nick, 'End of /ACCEPT list'], }; last SWITCH; } } my $record = $self->{state}{users}{uc_irc($nick)}; for (keys %{ $record->{accepts} }) { delete $record->{accepts}{$_} if !$self->state_nick_exists($_); } OUTER: for my $target (split /,/, $args->[0]) { if (my ($foo) = $target =~ /^\-(.+)$/) { my $dfoo = delete $record->{accepts}{uc_irc($foo)}; if (!$dfoo) { push @$ref, { prefix => $server, command => '458', params => [$nick, $foo, "doesn\'t exist"], }; } delete $self->{state}{accepts}{uc_irc($foo)}{uc_irc($nick)}; if (!keys %{ $self->{state}{accepts}{uc_irc($foo)} }) { delete $self->{state}{accepts}{uc_irc($foo)}; } next OUTER; } if (!$self->state_nick_exists($target)) { push @$ref, ['401', $target]; next OUTER; } # 457 ERR_ACCEPTEXIST if ($record->{accepts}{uc_irc($target)}) { push @$ref, { prefix => $server, command => '457', params => [ $nick, $self->state_user_nick($target), 'already exists', ], }; next OUTER; } if ($record->{umode} && $record->{umode} =~ /G/ && $self->_state_users_share_chan($nick, $target) ) { push @$ref, { prefix => $server, command => '457', params => [ $nick, $self->state_user_nick($target), 'already exists', ], }; next OUTER; } $self->{state}{accepts}{uc_irc($target)}{uc_irc($nick)} = $record->{accepts}{uc_irc($target)} = time; my @list = map { $self->state_user_nick($_) } keys %{ $record->{accepts} }; push @$ref, { prefix => $server, command => '281', params => [ $nick, join(' ', @list), ], } if @list; push @$ref, { prefix => $server, command => '282', params => [$nick, 'End of /ACCEPT list'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_quit { my $self = shift; my $nick = shift || return; my $qmsg = shift || 'Client Quit'; my $ref = [ ]; my $full = $self->state_user_full($nick); $nick = uc_irc($nick); my $record = delete $self->{state}{peers}{uc $self->server_name()}{users}{$nick}; $self->send_output( { prefix => $record->{nick}, command => 'QUIT', params => [$qmsg], }, $self->_state_connected_peers(), ) if !$record->{killed}; push @$ref, { prefix => $full, command => 'QUIT', params => [$qmsg], }; $self->send_event("daemon_quit", $full, $qmsg); # Remove for peoples accept lists for my $user (keys %{ $record->{accepts} }) { delete $self->{state}{users}{$user}{accepts}{uc_irc($nick)}; } # Okay, all 'local' users who share a common channel with user. my $common = { }; for my $uchan (keys %{ $record->{chans} }) { delete $self->{state}{chans}{$uchan}{users}{$nick}; for my $user ($self->state_chan_list($uchan)) { next if !$self->_state_is_local_user($user); $common->{$user} = $self->_state_user_route($user); } if (!keys %{ $self->{state}{chans}{$uchan}{users} }) { delete $self->{state}{chans}{$uchan}; } } push @$ref, $common->{$_} for keys %$common; $self->{state}{stats}{ops_online}-- if $record->{umode} =~ /o/; $self->{state}{stats}{invisible}-- if $record->{umode} =~ /i/; delete $self->{state}{users}{$nick} if !$record->{nick_collision}; delete $self->{state}{localops}{$record->{route_id}}; return @$ref if wantarray; return $ref; } sub _daemon_cmd_ping { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $args = [ @_ ]; my $count = @$args; my $ref = [ ]; SWITCH: { if (!$count) { push @$ref, [ '409' ]; last SWITCH; } if ($count >= 2 && !$self->state_peer_exists($args->[1])) { push @$ref, ['402', $args->[1]]; last SWITCH; } if ($count >= 2 && (uc $args->[1] ne uc $server)) { my $target = $self->_state_peer_name($args->[1]); $self->send_output( { command => 'PING', params => [$nick, $target], }, $self->_state_peer_route($args->[1]), ); last SWITCH; } push @$ref, { prefix => $server, command => 'PONG', params => [$server, $args->[0]], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_pong { my $self = shift; my $nick = shift || return; my $server = uc $self->server_name(); my $args = [ @_ ]; my $count = @$args; my $ref = [ ]; SWITCH: { if (!$count) { push @$ref, ['409']; last SWITCH; } if ($count >= 2 && !$self->state_peer_exists($args->[1])) { push @$ref, ['402', $args->[1]]; last SWITCH; } if ($count >= 2 && uc $args->[1] ne uc $server) { my $target = $self->_state_peer_name($args->[1]); $self->send_output( { command => 'PONG', params => [$nick, $target], }, $self->_state_peer_route($args->[1]), ); last SWITCH; } delete $self->{state}{users}{uc_irc($nick)}{pinged}; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_pass { my $self = shift; my $nick = shift || return; my $server = uc $self->server_name(); my $ref = [['462']]; return @$ref if wantarray; return $ref; } sub _daemon_cmd_user { my $self = shift; my $nick = shift || return; my $server = uc $self->server_name(); my $ref = [['462']]; return @$ref if wantarray; return $ref; } sub _daemon_cmd_oper { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { last SWITCH if $self->state_user_is_operator($nick); if (!$count || $count < 2) { push @$ref, ['461', 'OPER']; last SWITCH; } my $result = $self->_state_o_line($nick, @$args); if (!$result || $result <= 0) { push @$ref, ['491']; last SWITCH; } $self->{stats}{ops}++; my $record = $self->{state}{users}{uc_irc($nick)}; $record->{umode} .= 'o'; $self->{state}{stats}{ops_online}++; push @$ref, { prefix => $server, command => '381', params => [$nick, 'You are now an IRC operator'], }; my $reply = { prefix => $nick, command => 'MODE', params => [$nick, '+o'], }; $self->send_output( $reply, $self->_state_connected_peers(), ); $self->send_event( "daemon_umode", $self->state_user_full($nick), '+o', ); my $route_id = $self->_state_user_route($nick); $self->{state}{localops}{$route_id} = time; $self->antiflood($route_id, 0); push @$ref, $reply; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_die { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } $self->send_event("daemon_die", $nick); $self->shutdown(); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_rehash { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } $self->send_event("daemon_rehash", $nick); push @$ref, { prefix => $server, command => '383', params => [$nick, 'ircd.conf', 'Rehashing'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_locops { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count) { push @$ref, ['461', 'LOCOPS']; last SWITCH; } my $full = $self->state_user_full($nick); $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['LOCOPS - ' . $args->[0]], }, keys %{ $self->{state}{locops} }, ); $self->send_event("daemon_locops", $full, $args->[0]); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_wallops { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count) { push @$ref, ['461', 'WALLOPS']; last SWITCH; } my $full = $self->state_user_full($nick); $self->send_output( { prefix => $nick, command => 'WALLOPS', params => [$args->[0]], }, $self->_state_connected_peers(), ); $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['OPERWALL - ' . $args->[0]], }, keys %{ $self->{state}{operwall} }, ); $self->send_event("daemon_operwall", $full, $args->[0]); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_operwall { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count) { push @$ref, ['461', 'OPERWALL']; last SWITCH; } my $full = $self->state_user_full($nick); $self->send_output( { prefix => $nick, command => 'WALLOPS', params => [$args->[0]], }, $self->_state_connected_peers(), ); $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['OPERWALL - ' . $args->[0]], }, keys %{ $self->{state}{operwall} }, ); $self->send_event("daemon_operwall", $full, $args->[0]); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_connect { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count) { push @$ref, ['461', 'CONNECT']; last SWITCH; } if ($count >= 3 && !$self->state_peer_exists($args->[2])) { push @$ref, ['402', $args->[2]]; last SWITCH; } if ($count >= 3 && uc $server ne uc $args->[2]) { $args->[2] = $self->_state_peer_name($args->[2]); $self->send_output( { prefix => $nick, command => 'CONNECT', params => $args, }, $self->_state_peer_route($args->[2]), ); last SWITCH; } if (!$self->{config}{peers}{uc $args->[0]} || $self->{config}{peers}{uc $args->[0]}{type} ne 'r') { push @$ref, { command => 'NOTICE', params => [ $nick, "Connect: Host $args->[0] is not listed in ircd.conf", ], }; last SWITCH; } if (my $peer_name = $self->_state_peer_name($args->[0])) { push @$ref, { command => 'NOTICE', params => [ $nick, "Connect: Server $args->[0] already exists from $peer_name.", ], }; last SWITCH; } my $connector = $self->{config}{peers}{uc $args->[0]}; my $name = $connector->{name}; my $rport = $args->[1] || $connector->{rport}; my $raddr = $connector->{raddress}; $self->add_connector( remoteaddress => $raddr, remoteport => $rport, name => $name, ); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_squit { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count) { push @$ref, ['461', 'SQUIT']; last SWITCH; } if (!$self->state_peer_exists($args->[0]) || uc $server eq uc $args->[0]) { push @$ref, ['402', $args->[0]]; last SWITCH; } my $peer = uc $args->[0]; my $reason = $args->[1] || 'No Reason'; $args->[0] = $self->_state_peer_name($peer); $args->[1] = $reason; if ( !grep { $_ eq $peer } keys %{ $self->{state}{peers}{uc $server}{peers} }) { $self->send_output( { prefix => $nick, command => 'SQUIT', params => $args, }, $self->_state_peer_route($args->[0]), ); last SWITCH; } my $conn_id = $self->_state_peer_route($peer); $self->disconnect($conn_id, $reason); $self->send_output( { command => 'ERROR', params => [ join ' ', 'Closing Link:', $self->_client_ip($conn_id), $args->[0], "($nick)" ], }, $conn_id, ); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_rkline { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; # RKLINE [time] [ON ] :[reason] SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count || $count < 1) { push @$ref, ['461', 'RKLINE']; last SWITCH; } my $duration = 0; if ($args->[0] =~ /^\d+$/) { $duration = shift @$args; $duration = 14400 if $duration > 14400; } my $mask = shift @$args; if (!$mask) { push @$ref, ['461', 'RKLINE']; last SWITCH; } my ($user, $host) = split /\@/, $mask; if (!$user || !$host) { last SWITCH; } my $full = $self->state_user_full($nick); my $us = 0; my $ucserver = uc $server; if ($args->[0] && uc $args->[0] eq 'ON' && @$args < 2) { push @$ref, ['461', 'RKLINE']; last SWITCH; } my ($target, $reason); if ($args->[0] && uc $args->[0] eq 'ON') { $target = shift @$args; $reason = shift @{ $args } || 'No Reason'; my %targets; for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask($target, $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{ $self->_state_peer_route($peer) }++; } } } $self->send_output( { prefix => $nick, command => 'RKLINE', params => [$target, $duration, $user, $host, $reason], colonify => 0, }, grep { $self->_state_peer_capab($_, 'KLN') } keys %targets, ); } else { $us = 1; } if ($us) { $target = $server if !$target; if (!$reason) { $reason = pop @$args || 'No Reason'; } $self->send_event( "daemon_rkline", $full, $target, $duration, $user, $host, $reason, ); push @{ $self->{state}{rklines} }, { setby => $full, setat => time(), target => $target, duration => $duration, user => $user, host => $host, reason => $reason, }; for ($self->_state_local_users_match_rkline($user, $host)) { $self->_terminate_conn_error($_, 'K-Lined'); } } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_kline { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; # KLINE [time] [ ON ] :[reason] SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count || $count < 1) { push @$ref, ['461', 'KLINE']; last SWITCH; } my $duration = 0; if ($args->[0] =~ /^\d+$/) { $duration = shift @$args; $duration = 14400 if $duration > 14400; } my $mask = shift @$args; if (!$mask) { push @$ref, ['461', 'KLINE']; last SWITCH; } my ($user, $host); if ($mask !~ /\@/) { if (my $rogue = $self->_state_user_full($mask)) { ($user, $host) = (split /[!\@]/, $rogue )[1..2]; } else { push @$ref, ['401', $mask]; last SWITCH; } } else { ($user, $host) = split /\@/, $mask; } my $full = $self->state_user_full($nick); my $us = 0; my $ucserver = uc $server; if ($args->[0] && uc $args->[0] eq 'ON' && scalar @$args < 2) { push @$ref, ['461', 'KLINE']; last SWITCH; } my ($target, $reason); if ($args->[0] && uc $args->[0] eq 'ON') { $target = shift @$args; $reason = shift @$args || 'No Reason'; my %targets; for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask($target, $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{ $self->_state_peer_route($peer) }++; } } } $self->send_output( { prefix => $nick, command => 'KLINE', params => [ $target, $duration, $user, $host, $reason, ], colonify => 0, }, grep { $self->_state_peer_capab($_, 'KLN') } keys %targets, ); } else { $us = 1; } if ($us) { $target = $server if !$target; if (!$reason) { $reason = pop @$args || 'No Reason'; } $self->send_event( "daemon_kline", $full, $target, $duration, $user, $host, $reason, ); push @{ $self->{state}{klines} }, { setby => $full, setat => time, target => $target, duration => $duration, user => $user, host => $host, reason => $reason, }; for ($self->_state_local_users_match_gline($user, $host)) { $self->_terminate_conn_error($_, 'K-Lined'); } } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_unkline { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; # UNKLINE [ ON ] SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count || $count < 1) { push @$ref, ['461', 'UNKLINE']; last SWITCH; } my ($user, $host); if ($args->[0] !~ /\@/) { if (my $rogue = $self->state_user_full($args->[0])) { ($user, $host) = (split /[!\@]/, $rogue)[1..2] } else { push @$ref, ['401', $args->[0]]; last SWITCH; } } else { ($user, $host) = split /\@/, $args->[0]; } my $full = $self->state_user_full($nick); my $us = 0; my $ucserver = uc $server; if ($count > 1 && uc $args->[2] eq 'ON' && $count < 3) { push @$ref, ['461', 'UNKLINE']; last SWITCH; } if ($count > 1 && $args->[2] && uc $args->[2] eq 'ON') { my $target = $args->[2]; my %targets; for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask($target, $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{ $self->_state_peer_route( $peer ) }++; } } } $self->send_output( { prefix => $nick, command => 'UNKLINE', params => [$target, $user, $host], colonify => 0, }, grep { $self->_state_peer_capab($_, 'UNKLN') } keys %targets, ); } else { $us = 1; } if ($us) { my $target = $args->[3] || $server; $self->send_event( "daemon_unkline", $full, $target, $user, $host, ); my $i = 0; for (@{ $self->{state}{klines} }) { if ($_->{user} eq $user && $_->{host} eq $host) { splice @{ $self->{state}{klines} }, $i, 1; last; } ++$i; } } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_gline { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; # :klanker GLINE * meep.com :Fuckers SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count || $count < 2) { push @$ref, ['461', 'GLINE']; last SWITCH; } if ($args->[0] !~ /\@/ && !$self->state_nick_exists($args->[0])) { push @$ref, ['401', $args->[0]]; last SWITCH; } my ($user_part, $host_part); if ($args->[0] =~ /\@/) { ($user_part, $host_part) = (split /[!@]/, $self->state_user_full($args->[0]))[1..2]; } else { ($user_part, $host_part) = split /\@/, $args->[0]; } my $time = time; my $reason = join ' ', $args->[1], strftime('(%c)', localtime $time); my $full = $self->state_user_full($nick); push @{ $self->{state}{glines} }, { setby => $full, setat => time, user => $user_part, host => $host_part, reason => $reason, }; $self->send_output( { prefix => $nick, command => 'GLINE', params => [$user_part, $host_part, $reason], colonify => 0, }, grep { $self->_state_peer_capab($_, 'GLN') } $self->_state_connected_peers() ); $self->send_event( "daemon_gline", $full, $user_part, $host_part, $reason, ); for ($self->_state_local_users_match_gline($user_part, $host_part)) { $self->_terminate_conn_error($_, 'G-Lined'); } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_kill { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count) { push @$ref, ['461', 'KILL']; last SWITCH; } if ($self->state_peer_exists($args->[0])) { push @$ref, ['483']; last SWITCH; } if (!$self->state_nick_exists($args->[0])) { push @$ref, ['401', $args->[0]]; last SWITCH; } my $target = $self->state_user_nick($args->[0]); my $comment = $args->[1] || ''; if ($self->_state_is_local_user($target)) { my $route_id = $self->_state_user_route($target); $self->send_output( { prefix => $nick, command => 'KILL', params => [ $target, join('!', $server, $nick )." ($comment)", ] }, $self->_state_connected_peers(), ); $self->send_output( { prefix => $self->state_user_full($nick), command => 'KILL', params => [$target, $comment], }, $route_id, ); if ($route_id eq 'spoofed') { $self->call('del_spoofed_nick', $target, "Killed ($comment)"); } else { $self->{state}{conns}{$route_id}{killed} = 1; $self->_terminate_conn_error($route_id, "Killed ($comment)"); } } else { $self->{state}{users}{uc_irc($target)}{killed} = 1; $self->send_output( { prefix => $nick, command => 'KILL', params => [ $target, join('!', $server, $nick )." ($comment)", ], }, $self->_state_connected_peers(), ); $self->send_output( @{ $self->_daemon_peer_quit( $target, "Killed ($nick ($comment))" )} ); } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_nick { my $self = shift; my $nick = shift || return; my $new = shift; my $server = uc $self->server_name(); my $ref = [ ]; SWITCH: { if (!$new) { push @$ref, ['431']; last SWITCH; } my $nicklen = $self->server_config('NICKLEN'); $new = substr($new, 0, $nicklen) if length($new) > $nicklen; if ($nick eq $new) { last SWITCH; } if (!is_valid_nick_name($new)) { push @$ref, ['432', $new]; last SWITCH; } my $unick = uc_irc($nick); my $unew = uc_irc($new); if ($self->state_nick_exists($new) && $unick ne $unew) { push @$ref, ['433', $new]; last SWITCH; } my $full = $self->state_user_full($nick); my $record = $self->{state}{users}{$unick}; my $common = { $nick => $record->{route_id} }; for my $chan (keys %{ $record->{chans} }) { for my $user ($self->state_chan_list($chan)) { next if !$self->_state_is_local_user($user); $common->{$user} = $self->_state_user_route($user); } } if ($unick eq $unew) { $record->{nick} = $new; $record->{ts} = time; } else { $record->{nick} = $new; $record->{ts} = time; # Remove from peoples accept lists for (keys %{ $record->{accepts} }) { delete $self->{state}{users}{$_}{accepts}{$unick}; } delete $record->{accepts}; delete $self->{state}{users}{$unick}; $self->{state}{users}{$unew} = $record; delete $self->{state}{peers}{$server}{users}{$unick}; $self->{state}{peers}{$server}{users}{$unew} = $record; for my $chan (keys %{ $record->{chans} }) { $self->{state}{chans}{$chan}{users}{$unew} = delete $self->{state}{chans}{$chan}{users}{$unick}; } } my @peers = $self->_state_connected_peers(); $self->send_output( { prefix => $nick, command => 'NICK', params => [$new, $record->{ts}], }, @peers, ); $self->send_output( { prefix => $full, command => 'NICK', params => [$new], }, map{ $common->{$_} } keys %$common, ); $self->send_event("daemon_nick", $full, $new); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_away { my $self = shift; my $nick = shift || return; my $msg = shift; my $server = $self->server_name(); my $ref = [ ]; SWITCH: { my $record = $self->{state}{users}{uc_irc($nick)}; if (!$msg) { delete $record->{away}; $self->send_output( { prefix => $nick, command => 'AWAY', colonify => 0, }, $self->_state_connected_peers(), ); push @$ref, { prefix => $server, command => '305', params => ['You are no longer marked as being away'], }; last SWITCH; } $record->{away} = $msg; $self->send_output( { prefix => $nick, command => 'AWAY', params => [$msg], colonify => 0, }, $self->_state_connected_peers(), ); push @$ref, { prefix => $server, command => '306', params => ['You have been marked as being away'], }; } return @$ref if wantarray; return $ref; } # Pseudo cmd for ISupport 005 numerics sub _daemon_cmd_isupport { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; push @$ref, { prefix => $server, command => '005', params => [ $nick, join(' ', map { (defined $self->{config}{isupport}{$_} ? join '=', $_, $self->{config}{isupport}{$_} : $_ ) } qw(CALLERID EXCEPTS INVEX MAXCHANNELS MAXBANS MAXTARGETS NICKLEN TOPICLEN KICKLEN) ), 'are supported by this server', ], }; push @$ref, { prefix => $server, command => '005', params => [ $nick, join(' ', map { (defined $self->{config}{isupport}{$_} ? join '=', $_, $self->{config}{isupport}{$_} : $_ ) } qw(CHANTYPES PREFIX CHANMODES NETWORK CASEMAPPING DEAF) ), 'are supported by this server', ], }; return @$ref if wantarray; return $ref; } sub _daemon_cmd_info { my $self = shift; my $nick = shift || return; my $target = shift; my $server = $self->server_name(); my $ref = [ ]; SWITCH: { if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'INFO', params => [$self->_state_peer_name($target)], }, $self->_state_peer_route($target), ); last SWITCH; } for my $info (@{ $self->server_config('Info') }) { push @$ref, { prefix => $server, command => '371', params => [$nick, $info], }; } push @$ref, { prefix => $server, command => '374', params => [$nick, 'End of /INFO list.'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_version { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $target = shift; SWITCH: { if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'VERSION', params => [$self->_state_peer_name($target)], }, $self->_state_peer_route($target) ); last SWITCH; } push @$ref, { prefix => $server, command => '351', params => [ $nick, $self->server_version(), $server, 'eGHIMZ TS5ow', ], }; push @$ref, $_ for @{ $self->_daemon_cmd_isupport($nick) }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_admin { my $self = shift; my $nick = shift || return; my $target = shift; my $server = $self->server_name(); my $ref = [ ]; my $admin = $self->server_config('Admin'); SWITCH: { if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'ADMIN', params => [$self->_state_peer_name($target)], }, $self->_state_peer_route($target), ); last SWITCH; } push @$ref, { prefix => $server, command => '256', params => [$nick, $server, 'Administrative Info'], }; push @$ref, { prefix => $server, command => '257', params => [$nick, $admin->[0]], }; push @$ref, { prefix => $server, command => '258', params => [$nick, $admin->[1]], }; push @$ref, { prefix => $server, command => '259', params => [$nick, $admin->[2]], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_summon { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; push @$ref, '445'; return @$ref if wantarray; return $ref; } sub _daemon_cmd_time { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $target = shift; my $ref = [ ]; SWITCH: { if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'TIME', params => [$self->_state_peer_name($target)], }, $self->_state_peer_route($target), ); last SWITCH; } push @$ref, { prefix => $server, command => '391', params => [ $nick, $server, strftime("%A %B %e %Y -- %T %z", localtime), ], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_users { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $global = keys %{ $self->{state}{users} }; my $local = keys %{ $self->{state}{peers}{uc $server}{users} }; push @$ref, { prefix => $server, command => '265', params => [ $nick, "Current local users: $local Max: " . $self->{state}{stats}{maxlocal}, ], }; push @$ref, { prefix => $server, command => '266', params => [ $nick, "Current global users: $global Max: " . $self->{state}{stats}{maxglobal}, ], }; return @$ref if wantarray; return $ref; } sub _daemon_cmd_lusers { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $invisible = $self->{state}{stats}{invisible}; my $users = keys(%{ $self->{state}{users} }) - $invisible; my $servers = keys %{ $self->{state}{peers} }; my $chans = keys %{ $self->{state}{chans} }; my $local = keys %{ $self->{state}{peers}{uc $server}{users} }; my $peers = keys %{ $self->{state}{peers}{uc $server}{peers} }; my $totalconns = $self->{state}{stats}{conns_cumlative}; my $mlocal = $self->{state}{stats}{maxlocal}; my $conns = $self->{state}{stats}{maxconns}; push @$ref, { prefix => $server, command => '251', params => [ $nick, "There are $users users and $invisible invisible on " . "$servers servers", ], }; $servers--; push @$ref, { prefix => $server, command => '252', params => [ $nick, $self->{state}{stats}{ops_online}, "IRC Operators online", ] } if $self->{state}{stats}{ops_online}; push @$ref, { prefix => $server, command => '254', params => [$nick, $chans, "channels formed"], } if $chans; push @$ref, { prefix => $server, command => '255', params => [$nick, "I have $local clients and $peers servers"], }; push @$ref, $_ for $self->_daemon_cmd_users($nick); push @$ref, { prefix => $server, command => '250', params => [ $nick, "Highest connection count: $conns ($mlocal clients) " . "($totalconns connections received)", ], }; return @$ref if wantarray; return $ref; } sub _daemon_cmd_motd { my $self = shift; my $nick = shift || return; my $target = shift; my $server = $self->server_name(); my $ref = [ ]; my $motd = $self->server_config('MOTD'); SWITCH: { if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'MOTD', params => [$self->_state_peer_name($target)], }, $self->_state_peer_route($target), ); last SWITCH; } if ($motd && ref $motd eq 'ARRAY') { push @$ref, { prefix => $server, command => '375', params => [$nick, "- $server Message of the day - "], }; push @$ref, { prefix => $server, command => '372', params => [$nick, "- $_"] } for @$motd; push @$ref, { prefix => $server, command => '376', params => [$nick, "End of MOTD command"], }; } else { push @$ref, '422'; } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_stats { my $self = shift; my $nick = shift || return; my $char = shift; my $target = shift; my $server = $self->server_name(); my $ref = [ ]; SWITCH: { if (!$char) { push @$ref, ['461', 'STATS']; last SWITCH; } $char = substr $char, 0, 1; if ($char !~ /[ump]/) { push @$ref, { prefix => $server, command => '263', params => [ $nick, 'Server load is temporarily too heavy. ' .'Please wait a while and try again.' ], }; last SWITCH; } if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'STATS', params => [ $char, $self->_state_peer_name($target), ], }, $self->_state_peer_route($target), ); last SWITCH; } SWITCH2: { if ($char eq 'u') { my $uptime = time - $self->server_config('created'); my $days = int $uptime / 86400; my $remain = $uptime % 86400; my $hours = int $remain / 3600; $remain %= 3600; my $mins = int $remain / 60; $remain %= 60; push @$ref, { prefix => $server, command => '242', params => [ $nick, sprintf("Server Up %d days, %2.2d:%2.2d:%2.2d", $days, $hours, $mins, $remain), ], }; my $totalconns = $self->{state}{stats}{conns_cumlative}; my $local = $self->{state}{stats}{maxlocal}; my $conns = $self->{state}{stats}{maxconns}; push @$ref, { prefix => $server, command => '250', params => [ $nick, "Highest connection count: $conns ($local " ."clients) ($totalconns connections received)", ], }; last SWITCH2; } if ($char eq 'm') { my $cmds = $self->{state}{stats}{cmds}; push @$ref, { prefix => $server, command => '212', params => [ $nick, $_, $cmds->{$_}{local}, $cmds->{$_}{bytes}, $cmds->{$_}{remote}, ], } for sort keys %$cmds; last SWITCH2; } if ($char eq 'p') { my @ops = map { $self->_client_nickname( $_ ) } keys %{ $self->{state}{localops} }; for my $op (sort @ops) { my $record = $self->{state}{users}{uc_irc($op)}; push @$ref, { prefix => $server, command => '249', params => [ $nick, sprintf("[O] %s (%s\@%s) Idle: %u", $record->{nick}, $record->{auth}{ident}, $record->{auth}{hostname}, time - $record->{idle_time}), ], }; } push @$ref, { prefix => $server, command => '249', params => [$nick, scalar @ops . " OPER(s)"], }; last SWITCH2; } } push @$ref, { prefix => $server, command => '219', params => [$nick, $char, 'End of /STATS report'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_userhost { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $str = ''; for my $query (@_) { my ($proper, $userhost) = split /!/, $self->state_user_full($query); if ($proper && $userhost) { $str = join(' ', $str, $proper . ($self->state_user_is_operator($proper) ? '*' : '' ) . '=' . ($self->_state_user_away($proper) ? '-' : '+' ) . $userhost); } } push @$ref, { prefix => $server, command => '302', params => [$nick, ($str ? $str : ':')], }; return @$ref if wantarray; return $ref; } sub _daemon_cmd_ison { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$count) { push @$ref, ['461', 'ISON']; last SWITCH; } my $string = ''; $string = join ' ', map { $self->{state}{users}{uc_irc($_)}{nick} } grep { $self->state_nick_exists($_) } @$args; push @$ref, { prefix => $server, command => '303', params => [$nick, ($string =~ /\s+/ ? $string : ":$string")], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_list { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { my @chans; if (!$count) { @chans = map { $self->_state_chan_name($_) } keys %{ $self->{state}{chans} }; } my $last = pop @$args; if ($count && $last !~ /^[#&]/ && !$self->state_peer_exists($last)) { push @$ref, ['401', $last]; last SWITCH; } if ($count && $last !~ /^[#&]/ && uc $last ne uc $server) { $self->send_output( { prefix => $self->state_user_full($nick), command => 'LIST', params => [ @$args, $self->_state_peer_name($last), ], }, $self->_state_peer_route($last), ); last SWITCH; } if ($count && $last !~ /^[#&]/ && @$args == 0) { @chans = map { $self->_state_chan_name($_) } keys %{ $self->{state}{chans} }; } if ($count && $last !~ /^[#&]/ && @$args == 1) { $last = pop @$args; } if ($count && $last =~ /^[#&]/) { @chans = split /,/, $last; } push @$ref, { prefix => $server, command => '321', params => [$nick, 'Channel', 'Users Name'], }; my $count = 0; INNER: for my $chan (@chans) { if (!is_valid_chan_name($chan) || !$self->state_chan_exists($chan)) { if (!$count) { push @$ref, ['401', $chan]; last INNER; } $count++; next INNER; } $count++; if ($self->state_chan_mode_set( $chan, 'p') || $self->state_chan_mode_set($chan, 's') && !$self->state_is_chan_member($nick, $chan)) { next INNER; } my $record = $self->{state}{chans}{uc_irc($chan)}; push @$ref, { prefix => $server, command => '322', params => [ $nick, $record->{name}, scalar keys %{ $record->{users} }, (defined $record->{topic} ? $record->{topic}[0] : '' ), ], }; } push @$ref, { prefix => $server, command => '323', params => [$nick, 'End of /LIST'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_names { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { my (@chans, $query); if (!$count) { @chans = $self->state_user_chans($nick); $query = '*'; } my $last = pop @$args; if ($count && $last !~ /^[#&]/ && !$self->state_peer_exists($last)) { push @$ref, ['401', $last]; last SWITCH; } if ($count && $last !~ /^[#&]/ & uc $last ne uc $server) { $self->send_output( { prefix => $nick, command => 'NAMES', params => [@$args, $self->_state_peer_name($last)], }, $self->_state_peer_route($last), ); last SWITCH; } if ($count && $last !~ /^[#&]/ && @$args == 0) { @chans = $self->state_user_chans($nick); $query = '*'; } if ($count && $last !~ /^[#&]/ && @$args == 1) { $last = pop @$args; } if ($count && $last =~ /^[#&]/) { my ($chan) = grep { $_ && $self->state_chan_exists($_) && $self->state_is_chan_member($nick, $_) } split /,/, $last; @chans = (); if ($chan) { push @chans, $chan; $query = $self->_state_chan_name($chan); } else { $query = '*'; } } for my $chan (@chans) { my $record = $self->{state}{chans}{uc_irc($chan)}; my $type = '='; $type = '@' if $record->{mode} =~ /s/; $type = '*' if $record->{mode} =~ /p/; my $length = length($server)+3+length($chan)+length($nick)+7; my $buffer = ''; for my $name (sort $self->state_chan_list_prefixed($record->{name})) { if (length(join ' ', $buffer, $name) + $length > 510) { push @$ref, { prefix => $server, command => '353', params => [$nick, $type, $record->{name}, $buffer] }; $buffer = $name; next; } if ($buffer) { $buffer = join ' ', $buffer, $name; } else { $buffer = $name; } } push @$ref, { prefix => $server, command => '353', params => [$nick, $type, $record->{name}, $buffer], }; } push @$ref, { prefix => $server, command => '366', params => [$nick, $query, 'End of NAMES list'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_whois { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my ($first, $second) = @_; SWITCH: { if (!$first && !$second) { push @$ref, ['431']; last SWITCH; } if (!$second && $first) { $second = (split /,/, $first)[0]; $first = $server; } if ($first && $second) { $second = (split /,/, $second)[0]; } if (uc_irc($first) eq uc_irc($second) && $self->state_nick_exists($second)) { $first = $self->state_user_server($second); } my $query; my $target; $query = $first if !$second; $query = $second if $second; $target = $first if $second && uc $first ne uc$server; if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target) { $self->send_output( { prefix => $nick, command => 'WHOIS', params => [ $self->_state_peer_name($target), $second, ], }, $self->_state_peer_route($target), ); last SWITCH; } # Okay we got here *phew* if (!$self->state_nick_exists($query)) { push @$ref, ['401', $query]; } else { my $record = $self->{state}{users}{uc_irc($query)}; push @$ref, { prefix => $server, command => '311', params => [ $nick, $record->{nick}, $record->{auth}{ident}, $record->{auth}{hostname}, '*', $record->{ircname}, ], }; my @chans; LOOP: for my $chan (keys %{ $record->{chans} }) { if ($self->{state}{chans}{$chan}{mode} =~ /[ps]/ && !$self->state_is_chan_member($nick, $chan)) { next LOOP; } my $prefix = ''; $prefix .= '@' if $record->{chans}{$chan} =~ /o/; $prefix .= '%' if $record->{chans}{$chan} =~ /h/; $prefix .= '+' if $record->{chans}{$chan} =~ /v/; push @chans, $prefix . $self->{state}{chans}{$chan}{name}; } if (@chans) { my $buffer = ''; my $length = length($server) + 3 + length($nick) + length($record->{nick}) + 7; LOOP2: for my $chan (@chans) { if (length(join ' ', $buffer, $chan) + $length > 510) { push @$ref, { prefix => $server, command => '319', params => [$nick, $record->{nick}, $buffer], }; $buffer = $chan; next LOOP2; } if ($buffer) { $buffer = join ' ', $buffer, $chan; } else { $buffer = $chan; } } push @$ref, { prefix => $server, command => '319', params => [$nick, $record->{nick}, $buffer], }; } push @$ref, { prefix => $server, command => '312', params => [ $nick, $record->{nick}, $record->{server}, $self->_state_peer_desc($record->{server}), ], }; push @$ref, { prefix => $server, command => '301', params => [ $nick, $record->{nick}, $record->{away}, ], } if $record->{type} eq 'c' && $record->{away}; push @$ref, { prefix => $server, command => '313', params => [$nick, $record->{nick}, 'is an IRC Operator'], } if $record->{umode} && $record->{umode} =~ /o/; if ($record->{type} eq 'c' && ($self->server_config('whoisactually') or $self->state_user_is_operator($nick))) { push @$ref, { prefix => $server, command => '338', params => [ $nick, $record->{nick}, $record->{socket}[0], 'actually using host', ], }; } push @$ref, { prefix => $server, command => '317', params => [ $nick, $record->{nick}, time - $record->{idle_time}, $record->{conn_time}, 'seconds idle, signon time', ], } if $record->{type} eq 'c'; } push @$ref, { prefix => $server, command => '318', params => [$nick, $query, 'End of /WHOIS list.'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_who { my $self = shift; my $nick = shift || return; my ($who, $op_only) = @_; my $server = $self->server_name(); my $ref = [ ]; my $orig = $who; SWITCH: { if (!$who) { push @$ref, ['461', 'WHO']; last SWITCH; } if ($self->state_chan_exists($who) && $self->state_is_chan_member($nick, $who)) { my $record = $self->{state}{chans}{uc_irc($who)}; $who = $record->{name}; for my $member (keys %{ $record->{users} }) { my $rpl_who = { prefix => $server, command => '352', params => [$nick, $who], }; my $memrec = $self->{state}{users}{$member}; push @{ $rpl_who->{params} }, $memrec->{auth}{ident}; push @{ $rpl_who->{params} }, $memrec->{auth}{hostname}; push @{ $rpl_who->{params} }, $memrec->{server}; push @{ $rpl_who->{params} }, $memrec->{nick}; my $status = ($memrec->{away} ? 'G' : 'H'); $status .= '*' if $memrec->{umode} =~ /o/; $status .= '@' if $record->{users}{$member} =~ /o/; $status .= '%' if $record->{users}{$member} =~ /h/; $status .= '+' if $record->{users}{$member} !~ /o/ and $record->{users}{$member} =~ /v/; push @{ $rpl_who->{params} }, $status; push @{ $rpl_who->{params} }, "$memrec->{hops} " . $memrec->{ircname}; push @$ref, $rpl_who; } } if ($self->state_nick_exists($who)) { my $nickrec = $self->{state}{users}{uc_irc($who)}; $who = $nickrec->{nick}; my $rpl_who = { prefix => $server, command => '352', params => [$nick, '*'], }; push @{ $rpl_who->{params} }, $nickrec->{auth}{ident}; push @{ $rpl_who->{params} }, $nickrec->{auth}{hostname}; push @{ $rpl_who->{params} }, $nickrec->{server}; push @{ $rpl_who->{params} }, $nickrec->{nick}; my $status = ($nickrec->{away} ? 'G' : 'H'); $status .= '*' if $nickrec->{umode} =~ /o/; push @{ $rpl_who->{params} }, $status; push @{ $rpl_who->{params} }, "$nickrec->{hops} " . $nickrec->{ircname}; push @$ref, $rpl_who; } push @$ref, { prefix => $server, command => '315', params => [$nick, $orig, 'End of WHO list'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_mode { my $self = shift; my $nick = shift || return; my $chan = shift; my $server = $self->server_name(); my $maxmodes = $self->server_config('MODES'); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_chan_exists($chan)) { push @$ref, ['403', $chan]; last SWITCH; } my $record = $self->{state}{chans}{uc_irc($chan)}; $chan = $record->{name}; if (!$count && !$self->state_is_chan_member($nick, $chan)) { push @$ref, { prefix => $server, command => '324', params => [$nick, $chan, '+' . $record->{mode}], colonify => 0, }; push @$ref, { prefix => $server, command => '329', params => [$nick, $chan, $record->{ts}], colonify => 0, }; last SWITCH; } if (!$count) { push @$ref, { prefix => $server, command => '324', params => [ $nick, $chan, '+' . $record->{mode}, ($record->{ckey} || ()), ($record->{climit} || ()), ], colonify => 0, }; push @$ref, { prefix => $server, command => '329', params => [$nick, $chan, $record->{ts}], colonify => 0, }; last SWITCH; } my $unknown = 0; my $notop = 0; my $nick_is_op = $self->state_is_chan_op($nick, $chan); my $nick_is_hop = $self->state_is_chan_hop($nick, $chan); my $reply; my @reply_args; my $parsed_mode = parse_mode_line(@$args); my $mode_count = 0; while (my $mode = shift @{ $parsed_mode->{modes} }) { if ($mode !~ /[eIbklimnpstohv]/) { push @$ref, [ '472', (split //, $mode)[1], $chan, ] if !$unknown; $unknown++; next; } my $arg; if ($mode =~ /^(\+[ohvklbIe]|-[ohvbIe])/) { $arg = shift @{ $parsed_mode->{args} }; } if ($mode =~ /[-+]b/ && !defined $arg) { push @$ref, { prefix => $server, command => '367', params => [ $nick, $chan, @{ $record->{bans}{$_} }, ] } for keys %{ $record->{bans} }; push @$ref, { prefix => $server, command => '368', params => [$nick, $chan, 'End of Channel Ban List'], }; next; } if (!$nick_is_op && !$nick_is_hop) { push @$ref, ['482', $chan] if !$notop; $notop++; next; } if ($mode =~ /[-+]I/ && !defined $arg) { push @$ref, { prefix => $server, command => '346', params => [ $nick, $chan, @{ $record->{invex}{$_} }, ], } for keys %{ $record->{invex} }; push @$ref, { prefix => $server, command => '347', params => [$nick, $chan, 'End of Channel Invite List'] }; next; } if ($mode =~ /[-+]e/ && !defined $arg) { push @$ref, { prefix => $server, command => '348', params => [$nick, $chan, @{ $record->{excepts}{$_} } ] } for keys %{ $record->{excepts} }; push @$ref, { prefix => $server, command => '349', params => [ $nick, $chan, 'End of Channel Exception List', ], }; next; } if (!$nick_is_op && $nick_is_hop && $mode =~ /[op]/) { push @$ref, ['482', $chan] if !$notop; $notop++; next; } if (!$nick_is_op && $nick_is_hop && $record->{mode} =~ /p/ && $mode =~ /h/) { push @$ref, ['482', $chan] if !$notop; $notop++; next; } if (($mode =~ /^[-+][ohv]/ || $mode =~ /^\+[lk]/) && !defined $arg) { next; } if ($mode =~ /^[-+][ohv]/ && !$self->state_nick_exists($arg)) { next if ++$mode_count > $maxmodes; push @$ref, ['401', $arg]; next; } if ($mode =~ /^[-+][ohv]/ && !$self->state_is_chan_member($arg, $chan)) { next if ++$mode_count > $maxmodes; push @$ref, ['441', $chan, $self->state_user_nick($arg)]; next; } if (my ($flag, $char) = $mode =~ /^([-+])([ohv])/ ) { next if ++$mode_count > $maxmodes; if ($flag eq '+' && $record->{users}{uc_irc($arg)} !~ /$char/) { # Update user and chan record $arg = uc_irc($arg); if ($mode eq '+h' && $record->{users}{$arg} =~ /o/) { next; } if ($char eq 'h' && $record->{users}{$arg} =~ /v/) { $record->{users}{$arg} =~ s/v//g; $reply .= '-v'; push @reply_args, $self->state_user_nick($arg); } if ($char eq 'o' && $record->{users}{$arg} =~ /h/ ) { $record->{users}{$arg} =~ s/h//g; $reply .= '-h'; push @reply_args, $self->state_user_nick($arg); } $record->{users}{$arg} = join('', sort split //, $record->{users}{$arg} . $char); $self->{state}{users}{$arg}{chans}{uc_irc($chan)} = $record->{users}{$arg}; $reply .= $mode; push @reply_args, $self->state_user_nick($arg); } if ($flag eq '-' && $record->{users}{uc_irc($arg)} =~ /$char/) { # Update user and chan record $arg = uc_irc($arg); $record->{users}{$arg} =~ s/$char//g; $self->{state}{users}{$arg}{chans}{uc_irc($chan)} = $record->{users}{$arg}; $reply .= $mode; push @reply_args, $self->state_user_nick($arg); } next; } if ($mode eq '+l' && $arg =~ /^\d+$/ && $arg > 0) { next if ++$mode_count > $maxmodes; $reply .= $mode; push @reply_args, $arg; if ($record->{mode} !~ /l/) { $record->{mode} = join('', sort split //, $record->{mode} . 'l'); } $record->{climit} = $arg; next; } if ($mode eq '-l' && $record->{mode} =~ /l/) { $record->{mode} =~ s/l//g; delete $record->{climit}; $reply .= $mode; next; } if ($mode eq '+k' && $arg) { next if ++$mode_count > $maxmodes; $reply .= $mode; push @reply_args, $arg; if ($record->{mode} !~ /k/) { $record->{mode} = join('', sort split //, $record->{mode} . 'k'); } $record->{ckey} = $arg; next; } if ($mode eq '-k' && $record->{mode} =~ /k/) { $reply .= $mode; push @reply_args, '*'; $record->{mode} =~ s/k//g; delete $record->{ckey}; next; } # Bans if (my ($flag) = $mode =~ /([-+])b/) { next if ++$mode_count > $maxmodes; my $mask = normalize_mask($arg); my $umask = uc_irc $mask; if ($flag eq '+' && !$record->{bans}{$umask}) { $record->{bans}{$umask} = [$mask, $self->state_user_full($nick), time]; $reply .= $mode; push @reply_args, $mask; } if ($flag eq '-' && $record->{bans}{$umask}) { delete $record->{bans}{$umask}; $reply .= $mode; push @reply_args, $mask; } next; } # Invex if (my ($flag) = $mode =~ /([-+])I/) { next if ++$mode_count > $maxmodes; my $mask = normalize_mask( $arg ); my $umask = uc_irc $mask; if ($flag eq '+' && !$record->{invex}{$umask}) { $record->{invex}{$umask} = [$mask, $self->state_user_full($nick), time]; $reply .= $mode; push @reply_args, $mask; } if ($flag eq '-' && $record->{invex}{$umask}) { delete $record->{invex}{$umask}; $reply .= $mode; push @reply_args, $mask; } next; } # Exceptions if (my ($flag) = $mode =~ /([-+])e/) { next if ++$mode_count > $maxmodes; my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{excepts}{$umask}) { $record->{excepts}{$umask} = [$mask, $self->state_user_full($nick), time]; $reply .= $mode; push @reply_args, $mask; } if ($flag eq '-' && $record->{excepts}{$umask}) { delete $record->{excepts}{$umask}; $reply .= $mode; push @reply_args, $mask; } next; } # The rest should be argumentless. my ($flag, $char) = split //, $mode; if ($flag eq '+' && $record->{mode} !~ /$char/) { $reply .= $mode; $record->{mode} = join('', sort split //, $record->{mode} . $char); next; } if ($flag eq '-' && $record->{mode} =~ /$char/) { $reply .= $mode; $record->{mode} =~ s/$char//g; next; } } # while if ($reply) { $reply = unparse_mode_line($reply); my $output = { prefix => $self->state_user_full($nick), command => 'MODE', params => [$chan, $reply, @reply_args], colonify => 0, }; $self->_send_output_to_channel($chan, $output); } } # SWITCH return @$ref if wantarray; return $ref; } sub _daemon_cmd_join { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; my $route_id = $self->_state_user_route($nick); my $unick = uc_irc($nick); SWITCH: { my (@channels, @chankeys); if (!$count) { push @$ref, ['461', 'JOIN']; last SWITCH; } @channels = split /,/, $args->[0]; @chankeys = split /,/, $args->[1] if $args->[1]; my $channel_length = $self->server_config('CHANNELLEN'); LOOP: for my $channel (@channels) { my $uchannel = uc_irc($channel); if ($channel eq '0' and my @chans = $self->state_user_chans($nick)) { $self->_send_output_to_client( $route_id, (ref $_ eq 'ARRAY' ? @$_ : $_), ) for map { $self->_daemon_cmd_part($nick, $_) } @chans; next LOOP; } # Channel isn't valid if (!is_valid_chan_name($channel) || length $channel > $channel_length) { $self->_send_output_to_client( $route_id, '403', $channel, ); next LOOP; } # Too many channels if ($self->state_user_chans($nick) >= $self->server_config('MAXCHANNELS') && !$self->state_user_is_operator($nick)) { $self->_send_output_to_client( $route_id, '405', $channel, ); next LOOP; } # Channel doesn't exist if (!$self->state_chan_exists($channel)) { my $record = { name => $channel, ts => time, mode => 'nt', users => { $unick => 'o' }, }; $self->{state}{chans}{$uchannel} = $record; $self->{state}{users}{$unick}{chans}{$uchannel} = 'o'; my @peers = $self->_state_connected_peers(); $self->send_output( { command => 'SJOIN', params => [ $record->{ts}, $channel, '+' . $record->{mode}, '@' . $nick, ], }, @peers, ) if $channel !~ /^&/; my $output = { prefix => $self->state_user_full($nick), command => 'JOIN', params => [$channel], }; $self->send_output($output, $route_id); $self->send_event( "daemon_join", $output->{prefix}, $channel, ); $self->send_output( { prefix => $server, command => 'MODE', params => [$channel, '+' . $record->{mode}], }, $route_id, ); $self->_send_output_to_client( $route_id, (ref $_ eq 'ARRAY' ? @$_ : $_), ) for $self->_daemon_cmd_names($nick, $channel); $self->_send_output_to_client( $route_id, (ref $_ eq 'ARRAY' ? @$_ : $_ ), ) for $self->_daemon_cmd_topic($nick, $channel); next LOOP; } # Numpty user is already on channel if ($self->state_is_chan_member($nick, $channel)) { next LOOP; } my $chanrec = $self->{state}{chans}{$uchannel}; my $bypass; if ($self->state_user_is_operator($nick) && $self->{config}{OPHACKS}) { $bypass = 1; } # Channel is full if (!$bypass && $chanrec->{mode} =~ /l/ && keys %$chanrec >= $chanrec->{climit}) { $self->_send_output_to_client($route_id, '471', $channel); next LOOP; } my $chankey; $chankey = shift @chankeys if $chanrec->{mode} =~ /k/; # Channel +k and no key or invalid key provided if (!$bypass && $chanrec->{mode} =~ /k/ && (!$chankey || $chankey ne $chanrec->{ckey})) { $self->_send_output_to_client($route_id, '475', $channel); next LOOP; } # Channel +i and not INVEX if (!$bypass && $chanrec->{mode} =~ /i/ && !$self->_state_user_invited($nick, $channel)) { $self->_send_output_to_client($route_id, '473', $channel); next LOOP; } # Channel +b and no exception if (!$bypass && $self->_state_user_banned($nick, $channel)) { $self->_send_output_to_client($route_id, '474', $channel); next LOOP; } # JOIN the channel delete $self->{state}{users}{$unick}{invites}{$uchannel}; # Add user $self->{state}{users}{$unick}{chans}{$uchannel} = ''; $self->{state}{chans}{$uchannel}{users}{$unick} = ''; # Send JOIN message to peers and local users. $self->send_output( { prefix => $server, command => 'SJOIN', params => [$chanrec->{ts}, $channel, '+', $nick], }, $self->_state_connected_peers(), ) if $channel !~ /^&/; my $output = { prefix => $self->state_user_full($nick), command => 'JOIN', params => [$channel], }; $self->_send_output_to_client($route_id, $output); $self->_send_output_to_channel($channel, $output, $route_id); # Send NAMES and TOPIC to client $self->_send_output_to_client( $route_id, (ref $_ eq 'ARRAY' ? @$_ : $_), ) for $self->_daemon_cmd_names($nick, $channel); $self->_send_output_to_client( $route_id, (ref $_ eq 'ARRAY' ? @$_ : $_), ) for $self->_daemon_cmd_topic($nick, $channel); } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_part { my $self = shift; my $nick = shift || return; my $chan = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$chan) { push @$ref, ['461', 'PART']; last SWITCH; } if (!$self->state_chan_exists($chan)) { push @$ref, ['403', $chan]; last SWITCH; } if (!$self->state_is_chan_member($nick, $chan)) { push @$ref, ['442', $chan]; last SWITCH; } $self->_send_output_to_channel( $chan, { prefix => $self->state_user_full($nick), command => 'PART', params => [$chan, ($args->[0] || $nick)], }, ); $nick = uc_irc($nick); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$nick}; delete $self->{state}{users}{$nick}{chans}{$chan}; if (! keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_kick { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$count || $count < 2) { push @$ref, ['461', 'KICK']; last SWITCH; } my $chan = (split /,/, $args->[0])[0]; my $who = (split /,/, $args->[1])[0]; if (!$self->state_chan_exists($chan)) { push @$ref, ['403', $chan]; last SWITCH; } $chan = $self->_state_chan_name($chan); if (!$self->state_nick_exists($who) ) { push @$ref, ['401', $who]; last SWITCH; } $who = $self->state_user_nick($who); if (!$self->state_is_chan_op($nick, $chan)) { push @$ref, ['482', $chan]; last SWITCH; } if (!$self->state_is_chan_member($who, $chan)) { push @$ref, ['441', $who, $chan]; last SWITCH; } my $comment = $args->[2] || $who; $self->_send_output_to_channel( $chan, { prefix => $self->state_user_full($nick), command => 'KICK', params => [$chan, $who, $comment], }, ); $who = uc_irc($who); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$who}; delete $self->{state}{users}{$who}{chans}{$chan}; if (!keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_remove { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$count || $count < 2) { push @$ref, ['461', 'REMOVE']; last SWITCH; } my $chan = (split /,/, $args->[0])[0]; my $who = (split /,/, $args->[1])[0]; if (!$self->state_chan_exists($chan)) { push @$ref, ['403', $chan]; last SWITCH; } $chan = $self->_state_chan_name($chan); if (!$self->state_nick_exists($who)) { push @$ref, ['401', $who]; last SWITCH; } my $fullwho = $self->state_user_full($who); $who = (split /!/, $fullwho)[0]; if (!$self->state_is_chan_op($nick, $chan)) { push @$ref, ['482', $chan]; last SWITCH; } if (!$self->state_is_chan_member($who, $chan)) { push @$ref, ['441', $who, $chan]; last SWITCH; } my $comment = "Requested by $nick"; $comment .= qq{ "$args->[2]"} if $args->[2]; $self->_send_output_to_channel( $chan, { prefix => $fullwho, command => 'PART', params => [$chan, $comment], }, ); $who = uc_irc($who); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$who}; delete $self->{state}{users}{$who}{chans}{$chan}; if (! keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_invite { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$count || $count < 2) { push @$ref, ['461', 'INVITE']; last SWITCH; } my ($who, $chan) = @$args; if (!$self->state_nick_exists($who)) { push @$ref, ['401', $who]; last SWITCH; } $who = $self->state_user_nick($who); if (!$self->state_chan_exists($chan)) { push @$ref, ['403', $chan]; last SWITCH; } $chan = $self->_state_chan_name($chan); if (!$self->state_is_chan_member($nick, $chan)) { push @$ref, ['442', $chan]; last SWITCH; } if ($self->state_is_chan_member($who, $chan)) { push @$ref, ['443', $who, $chan]; last SWITCH; } if ($self->state_chan_mode_set($chan, 'i') && !$self->state_is_chan_op($nick, $chan)) { push @$ref, ['482', $chan]; last SWITCH; } my $local; if ($self->_state_is_local_user($who)) { my $record = $self->{state}{users}{uc_irc($who)}; $record->{invites}{uc_irc($chan)} = time; $local = 1; } my $away = $self->_state_user_away_msg($who); my $route_id = $self->_state_user_route($who); my $output = { prefix => $self->state_user_full($nick), command => 'INVITE', params => [$who, $chan], colonify => 0, }; if ($route_id eq 'spoofed') { $self->send_event( "daemon_invite", $output->{prefix}, @{ $output->{params} } ); } else { if (!$local) { $output->{prefix} = $nick; push @{ $output->{params} }, time; } $self->send_output($output, $route_id); } push @$ref, { prefix => $server, command => '341', params => [$chan, $who], }; if (defined $away) { push @$ref, { prefix => $server, command => '301', params => [$nick, $who, $away], }; } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_umode { my $self = shift; my $nick = shift || return; my $umode = shift; my $server = $self->server_name(); my $ref = [ ]; my $record = $self->{state}{users}{uc_irc($nick)}; if (!$umode) { push @$ref, { prefix => $server, command => '221', params => [$nick, '+' . $record->{umode}], }; } else { my $peer_ignore; my $parsed_mode = parse_mode_line($umode); my $route_id = $self->_state_user_route($nick); my $previous = $record->{umode}; while (my $mode = shift @{ $parsed_mode->{modes} }) { next if $mode eq '+o'; my ($action, $char) = split //, $mode; if ($action eq '+' && $record->{umode} !~ /$char/) { next if $char =~ /[wzl]a/ && $record->{umode} !~ /o/; $record->{umode} .= $char; if ($char eq 'i') { $self->{state}{stats}{invisible}++; $peer_ignore = delete $record->{_ignore_i_umode}; } if ($char eq 'w') { $self->{state}{wallops}{$route_id} = time; } if ($char eq 'z') { $self->{state}{operwall}{$route_id} = time; } if ($char eq 'l') { $self->{state}{locops}{$route_id} = time; } } if ($action eq '-' && $record->{umode} =~ /$char/) { $record->{umode} =~ s/$char//g; $self->{state}{stats}{invisible}-- if $char eq 'i'; if ($char eq 'o') { $self->{state}{stats}{ops_online}--; delete $self->{state}{localops}{$route_id}; $self->antiflood( $route_id, 1); } if ($char eq 'w') { delete $self->{state}{wallops}{$route_id}; } if ($char eq 'z') { delete $self->{state}{operwall}{$route_id}; } if ($char eq 'l') { delete $self->{state}{locops}{$route_id}; } } } $record->{umode} = join '', sort split //, $record->{umode}; my $peerprev = $previous; my $peerumode = $record->{umode}; $peerprev =~ s/[^aiow]//g; $peerumode =~ s/[^aiow]//g; my $pset = gen_mode_change($peerprev, $peerumode); my $set = gen_mode_change($previous, $record->{umode}); if ($pset && !$peer_ignore ) { my $hashref = { prefix => $nick, command => 'MODE', params => [$nick, $pset], }; $self->send_output( $hashref, $self->_state_connected_peers(), ); } if ($set) { my $hashref = { prefix => $nick, command => 'MODE', params => [$nick, $set], }; $self->send_event( "daemon_umode", $self->state_user_full($nick), $set ) if !$peer_ignore; push @$ref, $hashref; } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_topic { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH:{ if (!$count) { push @$ref, ['461', 'TOPIC']; last SWITCH; } if (!$self->state_chan_exists($args->[0])) { push @$ref, ['403', $args->[0]]; last SWITCH; } if ($self->state_chan_mode_set($args->[0], 's') && !$self->state_is_chan_member($nick, $args->[0])) { push @$ref, ['442', $args->[0]]; last SWITCH; } my $chan_name = $self->_state_chan_name($args->[0]); if ($count == 1 and my $topic = $self->state_chan_topic($args->[0])) { push @$ref, { prefix => $server, command => '332', params => [$nick, $chan_name, $topic->[0]], }; push @$ref, { prefix => $server, command => '333', params => [$nick, $chan_name, @{ $topic }[1..2]], }; last SWITCH; } if ($count == 1) { push @$ref, { prefix => $server, command => '331', params => [$nick, $chan_name, 'No topic is set'], }; last SWITCH; } if (!$self->state_is_chan_member($nick, $args->[0])) { push @$ref, ['442', $args->[0]]; last SWITCH; } if ($self->state_chan_mode_set($args->[0], 't') && !$self->state_is_chan_op($nick, $args->[0])) { push @$ref, ['482', $args->[0]]; last SWITCH; } my $record = $self->{state}{chans}{uc_irc($args->[0])}; my $topic_length = $self->server_config('TOPICLEN'); if (length $args->[0] > $topic_length) { $args->[1] = substr $args->[0], 0, $topic_length; } if ($args->[1] eq '') { delete $record->{topic}; } else { $record->{topic} = [ $args->[1], $self->state_user_full($nick), time, ]; } $self->_send_output_to_channel( $args->[0], { prefix => $self->state_user_full($nick), command => 'TOPIC', params => [$chan_name, $args->[1]], }, ); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_links { my $self = shift; my $nick = shift || return; my $target = shift; my $server = $self->server_name(); my $ref = [ ]; SWITCH:{ if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'LINKS', params => [$self->_state_peer_name($target)], }, $self->_state_peer_route($target) ); last SWITCH; } for ($self->_state_server_links($server, $server, $nick)) { push @$ref, $_; } push @$ref, { prefix => $server, command => '364', params => [ $nick, $server, $server, join( ' ', '0', $self->server_config('serverdesc')) ], }; push @$ref, { prefix => $server, command => '365', params => [$nick, '*', 'End of /LINKS list.'], }; } return @$ref if wantarray; return $ref; } sub _daemon_peer_squit { my $self = shift; my $peer_id = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; return if !$self->state_peer_exists($args->[0]); SWITCH: { if ($peer_id ne $self->_state_peer_route($args->[0])) { $self->send_output( { command => 'SQUIT', params => $args, }, $self->_state_peer_route($args->[0]), ); last SWITCH; } if ($peer_id eq $self->_state_peer_route($args->[0])) { $self->send_output( { command => 'SQUIT', params => $args, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_event("daemon_squit", @$args); my $quit_msg = join ' ', $self->_state_peer_for_peer($args->[0]), $args->[0]; for my $nick ($self->_state_server_squit($args->[0])) { my $output = { prefix => $self->state_user_full($nick), command => 'QUIT', params => [$quit_msg], }; my $common = { }; for my $uchan ($self->state_user_chans($nick)) { $uchan = uc_irc($uchan); delete $self->{state}{chans}{$uchan}{users}{$nick}; for my $user ($self->state_chan_list($uchan)) { next if !$self->_state_is_local_user($user); $common->{$user} = $self->_state_user_route($user); } if (!keys %{ $self->{state}{chans}{$uchan}{users} }) { delete $self->{state}{chans}{$uchan}; } } $self->send_output($output, values %$common); $self->send_event( "daemon_quit", $output->{prefix}, $output->{params}[0], ); my $record = delete $self->{state}{users}{$nick}; if ($record->{umode} =~ /o/) { $self->{state}{stats}{ops_online}--; } if ($record->{umode} =~ /i/) { $self->{state}{stats}{invisible}--; } } last SWITCH; } } return @$ref if wantarray; return $ref; } sub _daemon_peer_rkline { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; # :klanker RKLINE logserv.gumbynet.org.uk 600 ^m.*\ foo\.(com|uk|net)$ :Foo SWITCH: { if (!$count || $count < 5) { last SWITCH; } my $full = $self->state_user_full($nick); my $target = $args->[0]; my $us = 0; my $ucserver = uc $server; my %targets; for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask( $target, $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{$self->_state_peer_route($peer)}++; } } } delete $targets{$peer_id}; $self->send_output( { prefix => $nick, command => 'RKLINE', params => $args, colonify => 0, }, grep { $self->_state_peer_capab($_, 'KLN') } keys %targets, ); if ($us) { $self->send_event("daemon_rkline", $full, @$args); push @{ $self->{state}{rklines} }, { setby => $full, setat => time, target => $args->[0], duration => $args->[1], user => $args->[2], host => $args->[3], reason => $args->[4], }; $self->_terminate_conn_error($_, 'K-Lined') for $self->_state_local_users_match_rkline($args->[2], $args->[3]); } } return @$ref if wantarray; return $ref; } sub _daemon_peer_kline { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count || $count < 5) { last SWITCH; } my $full = $self->state_user_full($nick); my $target = $args->[0]; my $us = 0; my $ucserver = uc $server; my %targets; for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask($target, $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{$self->_state_peer_route($peer)}++; } } } delete $targets{$peer_id}; $self->send_output( { prefix => $nick, command => 'KLINE', params => $args, colonify => 0, }, grep { $self->_state_peer_capab($_, 'KLN') } keys %targets, ); if ($us) { $self->send_event("daemon_kline", $full, @$args); push @{ $self->{state}{klines} }, { setby => $full, setat => time(), target => $args->[0], duration => $args->[1], user => $args->[2], host => $args->[3], reason => $args->[4], }; $self->_terminate_conn_error($_, 'K-Lined') for $self->_state_local_users_match_gline($args->[2], $args->[3]); } } return @$ref if wantarray; return $ref; } sub _daemon_peer_unkline { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; # :klanker UNKLINE logserv.gumbynet.org.uk * moos.loud.me.uk SWITCH: { if (!$count || $count < 3) { last SWITCH; } my $full = $self->state_user_full($nick); my $target = $args->[0]; my $us = 0; my $ucserver = uc $server; my %targets; for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask($target, $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{$self->_state_peer_route($peer)}++; } } } delete $targets{$peer_id}; $self->send_output( { prefix => $nick, command => 'UNKLINE', params => $args, colonify => 0, }, grep { $self->_state_peer_capab($_, 'UNKLN') } keys %targets, ); if ($us) { $self->send_event("daemon_unkline", $full, @$args); my $i = 0; for (@{ $self->{state}{klines} }) { if ($_->{user} eq $args->[1] && $_->{host} eq $args->[2]) { splice (@{ $self->{state}{klines} }, $i, 1); last; } ++$i; } } } return @$ref if wantarray; return $ref; } sub _daemon_peer_gline { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; # :klanker GLINE * meep.com :Fuckers SWITCH: { if (!$count || $count < 3) { last SWITCH; } my $full = $self->state_user_full($nick); push @{ $self->{state}{glines} }, { setby => $full, setat => time, user => $args->[0], host => $args->[1], reason => $args->[2], }; $self->send_output( { prefix => $nick, command => 'GLINE', params => $args, colonify => 0, }, grep { $_ ne $peer_id && $self->_state_peer_capab($_, 'GLN') } $self->_state_connected_peers(), ); $self->send_event("daemon_gline", $full, @$args); $self->_terminate_conn_error($_, 'G-Lined') for $self->_state_local_users_match_gline($args->[0], $args->[1]); } return @$ref if wantarray; return $ref; } sub _daemon_peer_wallops { my $self = shift; my $peer_id = shift || return; my $prefix = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { my $full = $self->state_user_full($prefix) || $prefix; $self->send_output( { prefix => $prefix, command => 'WALLOPS', params => [$args->[0]], }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); if ($self->state_peer_exists($full)) { $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['OPERWALL - ' . $args->[0]], }, keys %{ $self->{state}{wallops} }, ); $self->send_event("daemon_wallops", $full, $args->[0]); } else { $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['OPERWALL - ' . $args->[0]], }, keys %{ $self->{state}{operwall} }, ); $self->send_event("daemon_operwall", $full, $args->[0]); } } return @$ref if wantarray; return $ref; } sub _daemon_peer_operwall { my $self = shift; my $peer_id = shift || return; my $prefix = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { my $full = $self->state_user_full($prefix) || $prefix; $self->send_output( { prefix => $prefix, command => 'WALLOPS', params => [$args->[0]], }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); if ($self->state_peer_exists($full)) { $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['OPERWALL - ' . $args->[0]], }, keys %{ $self->{state}{wallops} }, ); $self->send_event("daemon_wallops", $full, $args->[0]); } else { $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['OPERWALL - ' . $args->[0]], }, keys %{ $self->{state}{operwall} }, ); $self->send_event("daemon_operwall", $full, $args->[0]); } } return @$ref if wantarray; return $ref; } sub _daemon_peer_eob { my $self = shift; my $peer_id = shift || return; my $peer = shift || return; my $ref = [ ]; $self->send_event("daemon_eob", $peer); return @$ref if wantarray; return $ref; } sub _daemon_peer_kill { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if ($self->state_peer_exists($args->[0])) { last SWITCH; } if (!$self->state_nick_exists($args->[0])) { last SWITCH; } my $target = $self->state_user_nick($args->[0]); my $comment = $args->[1]; if ($self->_state_is_local_user($target)) { my $route_id = $self->_state_user_route($target); $self->send_output( { prefix => $nick, command => 'KILL', params => [ $target, join('!', $server, $comment), ], }, grep { $_ ne $peer_id } $self->_state_connected_peers() ); $self->send_output( { prefix => $self->state_user_full($nick), command => 'KILL', params => [ $target, join('!', $server, $comment), ], }, $route_id, ); if ($route_id eq 'spoofed') { $self->call( 'del_spoofed_nick', $target, "Killed ($comment)", ); } else { $self->{state}{conns}{$route_id}{killed} = 1; $self->_terminate_conn_error( $route_id, "Killed ($comment)", ); } } else { $self->{state}{users}{uc_irc($target)}{killed} = 1; $self->send_output( { prefix => $nick, command => 'KILL', params => [$target, join('!', $server, $comment)], }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_output( @{ $self->_daemon_peer_quit( $target, "Killed ($nick ($comment))" ) }, ); } } return @$ref if wantarray; return $ref; } sub _daemon_peer_svinfo { my $self = shift; my $peer_id = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; $self->{state}{conns}{$peer_id}{svinfo} = $args; return @$ref if wantarray; return $ref; } sub _daemon_peer_ping { my $self = shift; my $peer_id = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count) { last SWITCH; } if ($count >= 2 && uc $server ne uc $args->[1]) { $self->send_output( { command => 'PING', params => $args, }, $self->_state_peer_route($args->[1]), ) if $self->state_peer_exists($args->[1]); $self->send_output( { command => 'PING', params => $args, }, $self->_state_user_route($args->[1]), ) if $self->state_nick_exists($args->[1]); last SWITCH; } $self->send_output( { command => 'PONG', params => [$server, $args->[0]], }, $peer_id, ); } return @$ref if wantarray; return $ref; } sub _daemon_peer_pong { my $self = shift; my $peer_id = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count) { last SWITCH; } if ($count >= 2 && uc $self->server_name() ne uc $args->[1]) { $self->send_output( { command => 'PONG', params => $args, }, $self->_state_peer_route($args->[1]), ) if $self->state_peer_exists($args->[1]); $self->send_output( { command => 'PONG', params => $args, }, $self->_state_user_route($args->[1]), ) if $self->state_nick_exists($args->[1]); last SWITCH; } delete $self->{state}{conns}{$peer_id}{pinged}; } return @$ref if wantarray; return $ref; } sub _daemon_peer_server { my $self = shift; my $peer_id = shift || return; my $prefix = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; my $peer = $self->{state}{conns}{$peer_id}{name}; SWITCH: { if (!$count || $count < 2) { last SWITCH; } if ($self->state_peer_exists($args->[0])) { $self->_terminate_conn_error($peer_id, 'Server exists'); last SWITCH; } my $record = { name => $args->[0], hops => $args->[1], desc => ( $args->[2] || '' ), route_id => $peer_id, type => 'r', peer => $prefix, peers => { }, users => { }, }; my $uname = uc $record->{name}; $self->{state}{peers}{$uname} = $record; $self->{state}{peers}{uc $prefix}{peers}{$uname} = $record; $self->send_output( { prefix => $prefix, command => 'SERVER', params => [ $record->{name}, $record->{hops} + 1, $record->{desc}, ], }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_event( "daemon_server", $record->{name}, $prefix, $record->{hops}, $record->{desc}, ); } return @$ref if wantarray; return $ref; } sub _daemon_peer_quit { my $self = shift; my $nick = shift || return; my $qmsg = shift || 'Client Quit'; my $conn_id = shift; my $ref = [ ]; my $full = $self->state_user_full($nick); $nick = uc_irc($nick); my $record = delete $self->{state}{users}{$nick}; return $ref if !$record; $self->send_output( { prefix => $record->{nick}, command => 'QUIT', params => [$qmsg], }, grep { !$conn_id || $_ ne $conn_id } $self->_state_connected_peers(), ) if !$record->{killed}; push @$ref, { prefix => $full, command => 'QUIT', params => [$qmsg], }; $self->send_event("daemon_quit", $full, $qmsg); # Remove for peoples accept lists delete $self->{state}{users}{$_}{accepts}{uc_irc($nick)} for keys %{ $record->{accepts} }; # Okay, all 'local' users who share a common channel with user. my $common = { }; for my $uchan (keys %{ $record->{chans} }) { delete $self->{state}{chans}{$uchan}{users}{$nick}; for my $user ($self->state_chan_list($uchan)) { next if !$self->_state_is_local_user($user); $common->{$user} = $self->_state_user_route($user); } if (!keys %{ $self->{state}{chans}{$uchan}{users} }) { delete $self->{state}{chans}{$uchan}; } } push @$ref, $common->{$_} for keys %$common; $self->{state}{stats}{ops_online}-- if $record->{umode} =~ /o/; $self->{state}{stats}{invisible}-- if $record->{umode} =~ /i/; delete $self->{state}{peers}{uc $record->{server}}{users}{$nick}; return @$ref if wantarray; return $ref; } sub _daemon_peer_nick { my $self = shift; my $peer_id = shift || return; my $prefix = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; my $peer = $self->{state}{conns}{$peer_id}{name}; my $nicklen = $self->server_config('NICKLEN'); SWITCH: { if (!$count || $count < 8 && !$prefix) { $self->_terminate_conn_error( $peer_id, 'Not enough arguments to server command.', ); last SWITCH; } if ($prefix && $self->state_nick_exists($args->[0])) { $self->send_output( { prefix => $server, command => 'KILL', params => [$args->[0], "$server (Nick exists)"], }, $peer_id, ); my $unick = uc_irc($prefix); $self->{state}{users}{$unick}{nick_collision} = 1; $self->daemon_server_kill($prefix, 'Nick Collision', $peer_id); last SWITCH; } if ($prefix && length($args->[0]) > $nicklen) { $self->send_output( { prefix => $server, command => 'KILL', params => [$args->[0], "$server (Bad nickname)"], }, $peer_id, ); my $unick = uc_irc($prefix); $self->{state}{users}{$unick}{nick_collision} = 1; $self->daemon_server_kill($prefix, 'Nick Collision', $peer_id); last SWITCH; } if ($prefix) { my $full = $self->state_user_full($prefix); my $unick = uc_irc($prefix); my $new = $args->[0]; my $unew = uc_irc($new); my $ts = $args->[1] || time; my $record = $self->{state}{users}{$unick}; my $server = uc $record->{server}; if ($unick eq $unew) { $record->{nick} = $new; $record->{ts} = $ts; } else { $record->{nick} = $new; $record->{ts} = $ts; # Remove from peoples accept lists delete $self->{state}{users}{$_}{accepts}{$unick} for keys %{ $record->{accepts} }; delete $record->{accepts}; delete $self->{state}{users}{$unick}; $self->{state}{users}{$unew} = $record; delete $self->{state}{peers}{$server}{users}{$unick}; $self->{state}{peers}{$server}{users}{$unew} = $record; for my $chan (keys %{ $record->{chans} }) { $self->{state}{chans}{$chan}{users}{$unew} = delete $self->{state}{chans}{$chan}{users}{$unick}; } } my $common = { }; for my $chan (keys %{ $record->{chans} }) { for my $user ($self->state_chan_list($chan)) { next if !$self->_state_is_local_user($user); $common->{$user} = $self->_state_user_route($user); } } $self->send_output( { prefix => $prefix, command => 'NICK', params => $args, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_output( { prefix => $full, command => 'NICK', params => [$new], }, map{ $common->{$_} } keys %{ $common }, ); $self->send_event("daemon_nick", $full, $new); last SWITCH; } if ($self->state_nick_exists($args->[0]) and my ($nick, $userhost) = split /!/, $self->state_user_full($args->[0])) { my $unick = uc_irc $nick; my $incoming = join '@', @{ $args }[4..5]; if ($userhost eq $incoming) { my $ts = $self->{state}{users}{$unick}{ts}; if ($args->[2] > $ts) { $self->{state}{users}{$unick}{nick_collision} = 1; $self->daemon_server_kill( $nick, 'Nick Collision', $peer_id, ); } else { last SWITCH; } } else { my $ts = $self->{state}{users}{$unick}{ts}; if ($args->[2] < $ts) { $self->{state}{users}{$unick}{nick_collision} = 1; $self->daemon_server_kill( $nick, 'Nick Collision', $peer_id, ); } else { last SWITCH; } } } if (!$self->state_peer_exists($args->[6])) { last SWITCH; } if (length( $args->[0] ) > $nicklen) { $self->send_output( { prefix => $server, command => 'KILL', params => [$args->[0], "$server (Bad nickname)"], }, $peer_id, ); last SWITCH; } my $unick = uc_irc($args->[0]); $args->[3] =~ s/^\+//g; my $record = { nick => $args->[0], hops => $args->[1], ts => $args->[2], type => 'r', umode => $args->[3], auth => { ident => $args->[4], hostname => $args->[5], }, route_id => $peer_id, server => $args->[6], ircname => ( $args->[7] || '' ), }; $self->{state}{users}{ $unick } = $record; $self->{state}{stats}{ops_online}++ if $record->{umode} =~ /o/; $self->{state}{stats}{invisible}++ if $record->{umode} =~ /i/; $self->{state}{peers}{uc $record->{server}}{users}{$unick} = $record; $self->_state_update_stats(); $self->send_output( { command => 'NICK', params => $args, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_event("daemon_nick", @$args); } return @$ref if wantarray; return $ref; } sub _daemon_peer_part { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $chan = shift; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$chan) { last SWITCH; } if (!$self->state_chan_exists($chan)) { last SWITCH; } if (!$self->state_is_chan_member($nick, $chan)) { last SWITCH; } $self->_send_output_to_channel( $chan, { prefix => $self->state_user_full($nick), command => 'PART', params => [$chan, ($args->[0] || $nick)], }, $peer_id, ); $nick = uc_irc($nick); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$nick}; delete $self->{state}{users}{$nick}{chans}{$chan}; if (!keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub _daemon_peer_kick { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count || $count < 2) { last SWITCH; } my $chan = (split /,/, $args->[0])[0]; my $who = (split /,/, $args->[1])[0]; if (!$self->state_chan_exists($chan)) { last SWITCH; } $chan = $self->_state_chan_name($chan); if ( !$self->state_nick_exists($who)) { last SWITCH; } $who = $self->state_user_nick($who); if (!$self->state_is_chan_op($nick, $chan)) { last SWITCH; } if (!$self->state_is_chan_member($who, $chan)) { last SWITCH; } my $comment = $args->[2] || $who; $self->_send_output_to_channel( $chan, { prefix => $self->state_user_full($nick), command => 'KICK', params => [$chan, $who, $comment], }, $peer_id, ); $who = uc_irc($who); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$who}; delete $self->{state}{users}{$who}{chans}{$chan}; if (! keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub _daemon_peer_sjoin { my $self = shift; my $peer_id = shift || return; my $prefix = shift; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; #my $peer = $self->{state}{conns}{$peer_id}{name}; SWITCH: { if (!$count || $count < 4) { last SWITCH; } my $ts = $args->[0]; my $chan = $args->[1]; my $nicks = pop @{ $args }; my $ignore_modes = 0; if (!$self->state_chan_exists($chan)) { my $server = $self->server_name(); my $chanrec = { name => $chan, ts => $ts }; my @args = @{ $args }[2..$#{ $args }]; my $cmode = shift @args; $cmode =~ s/^\+//g; $chanrec->{mode} = $cmode; for my $mode (split //, $cmode) { my $arg; $arg = shift @args if $mode =~ /[lk]/; $chanrec->{climit} = $arg if $mode eq 'l'; $chanrec->{ckey} = $arg if $mode eq 'k'; } push @$args, $nicks; my $uchan = uc_irc($chanrec->{name}); for my $nick (split /\s+/, $nicks) { my $umode = ''; $umode .= 'o' if $nick =~ s/\@//g; $umode = 'h' if $nick =~ s/\%//g; $umode .= 'v' if $nick =~ s/\+//g; my $unick = uc_irc($nick); $chanrec->{users}{$unick} = $umode; $self->{state}{users}{$unick}{chans}{$uchan} = $umode; $self->send_event( "daemon_join", $self->state_user_full($nick), $chan, ); $self->send_event( "daemon_mode", $server, $chan, '+' . $umode, $nick, ) if $umode; } $self->{state}{chans}{$uchan} = $chanrec; $self->send_output( { prefix => $prefix, command => 'SJOIN', params => $args, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); last SWITCH; } my $chanrec = $self->{state}{chans}{uc_irc($chan)}; my @local_users = map { $self->_state_user_route($_) } grep { $self->_state_is_local_user($_) } keys %{ $chanrec->{users} }; if ($ts < $chanrec->{ts}) { # Incoming is older if ($nicks =~ /^\@/) { # Remove all modes expect bans/invex/excepts # deop/dehalfop/devoice all existing users my @deop; my @deop_list; my $common = { }; for my $user (keys %{ $chanrec->{users} }) { $common->{$user} = $self->_state_user_route($user) if $self->_state_is_local_user($user); next if !$chanrec->{users}{$user}; my $current = $chanrec->{users}{$user}; my $proper = $self->state_user_nick($user); $chanrec->{users}{$user} = ''; $self->{state}{users}{$user}{chans}{uc_irc($chanrec->{name})} = ''; push @deop, "-$current"; push @deop_list, $proper for split //, $current; } if (keys %$common && @deop) { my $server = $self->server_name(); $self->send_event( "daemon_mode", $server, $chanrec->{name}, unparse_mode_line(join '', @deop), @deop_list, ); my @output_modes; my $length = length($server) + 4 + length($chan) + 4; my @buffer = ('', ''); for my $deop (@deop) { my $arg = shift @deop_list; my $mode_line = unparse_mode_line($buffer[0].$deop); if (length(join ' ', $mode_line, $buffer[1], $arg) + $length > 510) { push @output_modes, { prefix => $server, command => 'MODE', colonify => 0, params => [ $chanrec->{name}, $buffer[0], split /\s+/, $buffer[1], ], }; $buffer[0] = $deop; $buffer[1] = $arg; next; } $buffer[0] = $mode_line; if ($buffer[1]) { $buffer[1] = join ' ', $buffer[1], $arg; } else { $buffer[1] = $arg; } } push @output_modes, { prefix => $server, command => 'MODE', colonify => 0, params => [ $chanrec->{name}, $buffer[0], split /\s+/, $buffer[1], ], }; $self->send_output($_, values %$common) for @output_modes; } my $origmode = $chanrec->{mode}; my @args = @{ $args }[2..$#{ $args }]; my $chanmode = shift @args; my $reply = ''; my @reply_args; for my $mode (grep { $_ ne '+' } split //, $chanmode) { my $arg; $arg = shift @args if $mode =~ /[lk]/; if ($mode eq 'l' && ($chanrec->{mode} !~ /l/ || $arg ne $chanrec->{climit})) { $reply .= '+' . $mode; push @reply_args, $arg; if ($chanrec->{mode} !~ /$mode/) { $chanrec->{mode} .= $mode; } $chanrec->{mode} = join '', sort split //, $chanrec->{mode}; $chanrec->{climit} = $arg; } elsif ($mode eq 'k' && ($chanrec->{mode} !~ /k/ || $arg ne $chanrec->{ckey})) { $reply .= '+' . $mode; push @reply_args, $arg; if ($chanrec->{mode} !~ /$mode/) { $chanrec->{mode} .= $mode; } $chanrec->{mode} = join '', sort split //, $chanrec->{mode}; $chanrec->{ckey} = $arg; } elsif ($chanrec->{mode} !~ /$mode/) { $reply .= '+' . $mode; $chanrec->{mode} = join '', sort split //, $chanrec->{mode}; } } if (keys %$common && ($reply || $origmode)) { $origmode = join '', grep { $chanmode !~ /$_/ } split //, ($origmode || ''); $chanrec->{mode} =~ s/[$origmode]//g if $origmode; $reply = '-' . $origmode . $reply if $origmode; if ($origmode && $origmode =~ /k/) { unshift @reply_args, '*'; delete $chanrec->{ckey}; } if ($origmode and $origmode =~ /l/) { delete $chanrec->{climit}; } $self->send_output( { prefix => $self->server_name(), command => 'MODE', colonify => 0, params => [ $chanrec->{name}, unparse_mode_line($reply), @reply_args, ], }, values %$common, ) if $reply; } # NOTICE HERE $self->send_output( { prefix => $self->server_name(), command => 'NOTICE', params => [ $chanrec->{name}, "*** Notice -- TS for " . $chanrec->{name} . " changed from " . $chanrec->{ts} . " to $ts", ], }, @local_users, ); $chanrec->{ts} = $ts; } elsif (grep { /^\@/ } $self->state_chan_list_prefixed($chan)) { $args->[0] = $chanrec->{ts}; } else { # NOTICE HERE $self->send_output( { prefix => $self->server_name(), command => 'NOTICE', params => [ $chanrec->{name}, "*** Notice -- TS for " . $chanrec->{name} . " changed from " . $chanrec->{ts} . " to $ts", ], }, @local_users, ); $chanrec->{ts} = $ts; } } elsif ($ts > $chanrec->{ts}) { # Incoming is younger if ($nicks !~ /^\@/) { $args->[0] = $chanrec->{ts}; } elsif (grep { /^\@/ } $self->state_chan_list_prefixed($chan)) { pop @$args while $#{ $args } > 2; $args->[2] = '+'; $args->[0] = $chanrec->{ts}; $nicks = join ' ', map { my $s = $_; $s =~ s/[@%+]//g; $s; } split /\s+/, $nicks; } else { $chanrec->{ts} = $ts; } } # Propagate SJOIN to connected peers except the one that told us. push @$args, $nicks; $self->send_output( { prefix => $prefix, command => 'SJOIN', params => $args, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); # Generate appropriate JOIN messages for all local # channel members my $uchan = uc_irc($chanrec->{name}); #my @local_users = map { $self->_state_user_route($_) } # grep { $self->_state_is_local_user($_) } # keys %{ $chanrec->{users} }; my $modes; my @mode_parms; for my $nick (split /\s+/, $nicks) { my $proper = $nick; $proper =~ s/[@%+]//g; $nick = uc_irc($nick); my $umode = ''; my @op_list; $umode .= 'o' if $nick =~ s/\@//g; $umode = 'h' if $nick =~ s/\%//g; $umode .= 'v' if $nick =~ s/\+//g; $chanrec->{users}{$nick} = $umode; $self->{state}{users}{$nick}{chans}{$uchan} = $umode; push @op_list, $proper for split //, $umode; my $output = { prefix => $self->state_user_full($nick), command => 'JOIN', params => [$chanrec->{name}], }; $self->send_output($output, @local_users); $self->send_event( "daemon_join", $output->{prefix}, $chanrec->{name}, ); if ($umode) { $modes .= $umode; push @mode_parms, @op_list; } } if ($modes) { my $server = $self->server_name(); $self->send_event( "daemon_mode", $server, $chanrec->{name}, '+' . $modes, @mode_parms, ); my @output_modes; my $length = length($server) + 4 + length($chan) + 4; my @buffer = ('+', ''); for my $umode (split //, $modes) { my $arg = shift @mode_parms; if (length(join ' ', @buffer, $arg) + $length > 510) { push @output_modes, { prefix => $server, command => 'MODE', colonify => 0, params => [ $chanrec->{name}, $buffer[0], split /\s+/, $buffer[1], ], }; $buffer[0] = "+$umode"; $buffer[1] = $arg; next; } $buffer[0] .= $umode; if ($buffer[1]) { $buffer[1] = join ' ', $buffer[1], $arg; } else { $buffer[1] = $arg; } } push @output_modes, { prefix => $server, command => 'MODE', colonify => 0, params => [ $chanrec->{name}, $buffer[0], split /\s+/, $buffer[1], ], }; $self->send_output($_, @local_users) for @output_modes; } } return @$ref if wantarray; return $ref; } sub _daemon_peer_mode { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $chan = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = scalar @$args; SWITCH: { if (!$self->state_chan_exists($chan)) { last SWITCH; } my $record = $self->{state}{chans}{uc_irc($chan)}; $chan = $record->{name}; my $full; $full = $self->state_user_full($nick) if $self->state_nick_exists($nick); my $reply; my @reply_args; my $parsed_mode = parse_mode_line(@$args); while (my $mode = shift (@{ $parsed_mode->{modes} })) { my $arg; $arg = shift @{ $parsed_mode->{args} } if $mode =~ /^(\+[ohvklbIe]|-[ohvbIe])/; if (my ($flag,$char) = $mode =~ /^(\+|-)([ohv])/) { if ($flag eq '+' && $record->{users}{uc_irc($arg)} !~ /$char/) { # Update user and chan record $arg = uc_irc($arg); next if $mode eq '+h' && $record->{users}{$arg} =~ /o/; if ($char eq 'h' && $record->{users}{$arg} =~ /v/) { $record->{users}{$arg} =~ s/v//g; $reply .= '-v'; push @reply_args, $self->state_user_nick($arg); } if ($char eq 'o' && $record->{users}{$arg} =~ /h/) { $record->{users}{$arg} =~ s/h//g; $reply .= '-h'; push @reply_args, $self->state_user_nick($arg); } $record->{users}{$arg} = join('', sort split //, $record->{users}{$arg} . $char); $self->{state}{users}{$arg}{chans}{uc_irc($chan)} = $record->{users}{$arg}; $reply .= "+$char"; push @reply_args, $self->state_user_nick($arg); } if ($flag eq '-' && $record->{users}{uc_irc($arg)} =~ /$char/) { # Update user and chan record $arg = uc_irc($arg); $record->{users}{$arg} =~ s/$char//g; $self->{state}{users}{$arg}{chans}{uc_irc($chan)} = $record->{users}{$arg}; $reply .= "-$char"; push @reply_args, $self->state_user_nick($arg); } next; } if ($mode eq '+l' && $arg =~ /^\d+$/ && $arg > 0) { $record->{mode} = join('', sort split //, $record->{mode} . 'l' ) if $record->{mode} !~ /l/; $record->{climit} = $arg; $reply .= '+l'; push @reply_args, $arg; next; } if ($mode eq '-l' && $record->{mode} =~ /l/) { $record->{mode} =~ s/l//g; delete $record->{climit}; $reply .= '-l'; next; } if ($mode eq '+k' && $arg) { $record->{mode} = join('', sort split //, $record->{mode} . 'k') if $record->{mode} !~ /k/; $record->{ckey} = $arg; $reply .= '+k'; push @reply_args, $arg; next; } if ($mode eq '-k' && $record->{mode} =~ /k/) { $record->{mode} =~ s/k//g; delete $record->{ckey}; $reply .= '-k'; next; } # Bans if (my ($flag) = $mode =~ /(\+|-)b/) { my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{bans}{$umask} ) { $record->{bans}{$umask} = [$mask, ($full || $server), time]; $reply .= '+b'; push @reply_args, $mask; } if ($flag eq '-' && $record->{bans}{$umask}) { delete $record->{bans}{$umask}; $reply .= '-b'; push @reply_args, $mask; } next; } # Invex if (my ($flag) = $mode =~ /(\+|-)I/) { my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{invex}{$umask}) { $record->{invex}{$umask} = [$mask, ($full || $server), time]; $reply .= '+I'; push @reply_args, $mask; } if ($flag eq '-' && $record->{invex}{$umask}) { delete $record->{invex}{$umask}; $reply .= '-I'; push @reply_args, $mask; } next; } # Exceptions if (my ($flag) = $mode =~ /(\+|-)e/) { my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{excepts}{$umask}) { $record->{excepts}{$umask} = [$mask, ($full || $server), time]; $reply .= '+e'; push @reply_args, $mask; } if ($flag eq '-' && $record->{excepts}{$umask}) { delete $record->{excepts}{$umask}; $reply .= '-e'; push @reply_args, $mask; } next; } # The rest should be argumentless. my ($flag, $char) = split //, $mode; if ( $flag eq '+' && $record->{mode} !~ /$char/) { $record->{mode} = join('', sort split //, $record->{mode} . $char); $reply .= "+$char"; next; } if ($flag eq '-' && $record->{mode} =~ /$char/) { $record->{mode} =~ s/$char//g; $reply .= "-$char"; next; } } # while unshift @$args, $record->{name}; if ($reply) { my $parsed_line = unparse_mode_line($reply); $self->send_output( { prefix => $nick, command => 'MODE', colonify => 0, params => [ $record->{name}, $parsed_line, @reply_args, ], }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_output( { prefix => ($full || $server), command => 'MODE', colonify => 0, params => [ $record->{name}, $parsed_line, @reply_args, ], }, map { $self->_state_user_route($_) } grep { $self->_state_is_local_user($_) } keys %{ $record->{users} }, ); $self->send_event( "daemon_mode", ($full || $server), $record->{name}, $parsed_line, @reply_args, ); } } # SWITCH return @$ref if wantarray; return $ref; } sub _daemon_peer_umode { my $self = shift; my $peer_id = shift || return; my $prefix = shift || return; my $nick = shift || return; my $umode = shift; my $server = $self->server_name(); my $ref = [ ]; my $record = $self->{state}{users}{uc_irc($nick)}; my $parsed_mode = parse_mode_line($umode); while (my $mode = shift @{ $parsed_mode->{modes} }) { my ($action, $char) = split //, $mode; if ($action eq '+' && $record->{umode} !~ /$char/) { $record->{umode} .= $char; $self->{state}{stats}{invisible}++ if $char eq 'i'; if ($char eq 'o') { $self->{state}{stats}{ops_online}++; } } if ($action eq '-' && $record->{umode} =~ /$char/) { $record->{umode} =~ s/$char//g; $self->{state}{stats}{invisible}-- if $char eq 'i'; if ($char eq 'o') { $self->{state}{stats}{ops_online}--; } } } $self->send_output( { prefix => $prefix, command => 'MODE', params => [$nick, $umode], }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_event( "daemon_umode", $self->state_user_full($nick), $umode, ); return @$ref if wantarray; return $ref; } sub _daemon_peer_message { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $type = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count) { push @$ref, ['461', $type]; last SWITCH; } if ($count < 2 || !$args->[1]) { push @$ref, ['412']; last SWITCH; } my $targets = 0; my $max_targets = $self->server_config('MAXTARGETS'); my $full = $self->state_user_full($nick); my $targs = $self->_state_parse_msg_targets($args->[0]); LOOP: for my $target (keys %$targs) { my $targ_type = shift @{ $targs->{$target} }; if ($targ_type =~ /(server|host)mask/ && !$self->state_user_is_operator($nick)) { push @$ref, ['481']; next LOOP; } if ($targ_type =~ /(server|host)mask/ && $targs->{$target}[0] !~ /\./) { push @$ref, ['413', $target]; next LOOP; } if ($targ_type =~ /(server|host)mask/ && $targs->{$target}[0] !~ /\x2E.*[\x2A\x3F]+.*$/) { push @$ref, ['414', $target]; next LOOP; } if ($targ_type eq 'channel_ext' && !$self->state_chan_exists($targs->{$target}[1])) { push @$ref, ['401', $targs->{$target}[1]]; next LOOP; } if ($targ_type eq 'channel' && !$self->state_chan_exists($target)) { push @$ref, ['401', $target]; next LOOP; } if ($targ_type eq 'nick' && !$self->state_nick_exists($target)) { push @$ref, ['401', $target]; next LOOP; } if ($targ_type eq 'nick_ext' && !$self->state_peer_exists($targs->{$target}[1])) { push @$ref, ['402', $targs->{$target}[1]]; next LOOP; } $targets++; if ($targets > $max_targets) { push @$ref, ['407', $target]; last SWITCH; } # $$whatever if ($targ_type eq 'servermask') { my $us = 0; my %targets; my $ucserver = uc $self->server_name(); for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask($targs->{$target}[0], $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{ $self->_state_peer_route($peer) }++; } } } delete $targets{$peer_id}; $self->send_output( { prefix => $nick, command => $type, params => [$target, $args->[1]], }, keys %targets, ); if ($us) { my $local = $self->{state}{peers}{uc $self->server_name()}{users}; my @local; my $spoofed = 0; for my $luser (values %$local) { if ($luser->{route_id} eq 'spoofed') { $spoofed = 1; } else { push @local, $luser->{route_id}; } } $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, @local, ); $self->send_event( "daemon_" . lc $type, $full, $target, $args->[1], ) if $spoofed; } next LOOP; } # $#whatever if ($targ_type eq 'hostmask') { my $spoofed = 0; my %targets; my @local; HOST: for my $luser (values %{ $self->{state}{users} }) { next HOST if !matches_mask( $targs->{$target}[0], $luser->{auth}{hostname}); if ($luser->{route_id} eq 'spoofed') { $spoofed = 1; } elsif ( $luser->{type} eq 'r') { $targets{$luser->{route_id}}++; } else { push @local, $luser->{route_id}; } } delete $targets{$peer_id}; $self->send_output( { prefix => $nick, command => $type, params => [$target, $args->[1]], }, keys %targets, ); $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, @local, ); $self->send_event( "daemon_" . lc $type, $full, $target, $args->[1], ) if $spoofed; next LOOP; } if ($targ_type eq 'nick_ext') { $targs->{$target}[1] = $self->_state_peer_name($targs->{$target}[1]); if ($targs->{$target}[2] && !$self->state_user_is_operator($nick)) { push @$ref, ['481']; next LOOP; } if ($targs->{$target}[1] ne $self->server_name()) { $self->send_output( { prefix => $nick, command => $type, params => [$target, $args->[1]], }, $self->_state_peer_route($targs->{$target}[1]), ); next LOOP; } if (uc $targs->{$target}[0] eq 'OPERS') { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; next LOOP; } $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, keys %{ $self->{state}{localops} }, ); next LOOP; } my @local = $self->_state_find_user_host( $targs->{$target}[0], $targs->{$target}[2], ); if (@local == 1) { my $ref = shift @local; if ($ref->[0] eq 'spoofed') { $self->send_event( "daemon_" . lc $type, $full, $ref->[1], $args->[1], ); } else { $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, $ref->[0], ); } } else { push @$ref, ['407', $target]; next LOOP; } } my $channel; my $status_msg; if ($targ_type eq 'channel') { $channel = $self->_state_chan_name($target); } if ($targ_type eq 'channel_ext') { $channel = $self->_state_chan_name($targs->{target}[1]); $status_msg = $targs->{target}[0]; } if ($channel && $status_msg && !$self->state_user_chan_mode($nick, $channel)) { push @$ref, ['482', $target]; next LOOP; } if ($channel && $self->state_chan_mode_set($channel, 'n') && !$self->state_is_chan_member($nick, $channel)) { push @$ref, ['404', $channel]; next LOOP; } if ($channel && $self->state_chan_mode_set($channel, 'm') && !$self->state_user_chan_mode($nick, $channel)) { push @$ref, ['404', $channel]; next LOOP; } if ($channel && $self->_state_user_banned($nick, $channel) && !$self->state_user_chan_mode($nick, $channel)) { push @$ref, ['404', $channel]; next LOOP; } if ($channel) { my $common = { }; my $msg = { command => $type, params => [ ($status_msg ? $target : $channel), $args->[1], ], }; for my $member ($self->state_chan_list($channel, $status_msg)) { next if $self->_state_user_is_deaf($member); $common->{ $self->_state_user_route($member) }++; } delete $common->{$peer_id}; for my $route_id (keys %$common) { $msg->{prefix} = $nick; if ($self->_connection_is_client($route_id)) { $msg->{prefix} = $full; } if ($route_id ne 'spoofed') { $self->send_output($msg, $route_id); } else { my $tmsg = $type eq 'PRIVMSG' ? 'public' : 'notice'; $self->send_event( "daemon_$tmsg", $full, $channel, $args->[1], ); } } next LOOP; } my $server = $self->server_name(); if ($self->state_nick_exists($target)) { $target = $self->state_user_nick($target); if (my $away = $self->_state_user_away_msg($target)) { push @$ref, { prefix => $server, command => '301', params => [$nick, $target, $away], }; } my $targ_umode = $self->state_user_umode($target); # Target user has CALLERID on if ($targ_umode && $targ_umode =~ /[Gg]/) { my $targ_rec = $self->{state}{users}{uc_irc($target) }; if (($targ_umode =~ /G/ && ( !$self->state_users_share_chan($target, $nick) || !$targ_rec->{accepts}{uc_irc($nick)})) || ($targ_umode =~ /g/ && !$targ_rec->{accepts}{uc_irc($nick)})) { push @$ref, { prefix => $server, command => '716', params => [ $nick, $target, 'is in +g mode (server side ignore)', ], }; if (!$targ_rec->{last_caller} || (time - $targ_rec->{last_caller} ) >= 60) { my ($n, $uh) = split /!/, $self->state_user_full($nick); $self->send_output( { prefix => $server, command => '718', params => [ $target, "$n\[$uh\]", 'is messaging you, and you are umode +g.' ], }, $targ_rec->{route_id}, ) if $targ_rec->{route_id} ne 'spoofed'; push @$ref, { prefix => $server, command => '717', params => [ $nick, $target, 'has been informed that you messaged them.', ], }; } $targ_rec->{last_caller} = time(); next LOOP; } } my $msg = { prefix => $nick, command => $type, params => [$target, $args->[1]], }; my $route_id = $self->_state_user_route($target); if ($route_id eq 'spoofed') { $msg->{prefix} = $full; $self->send_event( "daemon_" . lc $type, $full, $target, $args->[1], ); } else { if ($self->_connection_is_client($route_id)) { $msg->{prefix} = $full; } $self->send_output($msg, $route_id); } next LOOP; } } } return @$ref if wantarray; return $ref; } sub _daemon_peer_topic { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH:{ if (!$count) { last SWITCH; } if (!$self->state_chan_exists($args->[0])) { last SWITCH; } my $chan_name = $self->_state_chan_name($args->[0]); my $record = $self->{state}{chans}{uc_irc($args->[0])}; $record->{topic} = [$args->[1], $self->state_user_full($nick), time]; $self->_send_output_to_channel( $args->[0], { prefix => $self->state_user_full($nick), command => 'TOPIC', params => [$chan_name, $args->[1]], }, $peer_id, ); } return @$ref if wantarray; return $ref; } sub _daemon_peer_invite { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count || $count < 3) { last SWITCH; } my ($who, $chan) = @$args; $who = $self->state_user_nick($who); $chan = $self->_state_chan_name($chan); my $local; if ($self->_state_is_local_user($who)) { my $record = $self->{state}{users}{uc_irc($who)}; $record->{invites}{uc_irc($chan)} = time; $local = 1; } my $route_id = $self->_state_user_route($who); my $output = { prefix => $self->state_user_full($nick), command => 'INVITE', params => [$who, $chan], colonify => 0, }; if ($route_id eq 'spoofed') { $self->send_event( "daemon_invite", $output->{prefix}, @{ $output->{params} }, ); } else { if (!$local) { $output->{prefix} = $nick; push @{ $output->{params} }, $args->[2]; } $self->send_output($output, $route_id); } } return @$ref if wantarray; return $ref; } sub _daemon_peer_away { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $msg = shift; my $server = $self->server_name(); my $ref = [ ]; SWITCH: { my $record = $self->{state}{users}{uc_irc($nick)}; if (!$msg) { delete $record->{away}; $self->send_output( { prefix => $nick, command => 'AWAY', colonify => 0, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); last SWITCH; } $record->{away} = $msg; $self->send_output( { prefix => $nick, command => 'AWAY', params => [$msg], colonify => 0, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); } return @$ref if wantarray; return $ref; } sub _state_create { my $self = shift; $self->_state_delete(); # Connection specific tables $self->{state}{conns} = { }; # IRC State specific $self->{state}{users} = { }; $self->{state}{peers} = { }; $self->{state}{chans} = { }; # Register ourselves as a peer. $self->{state}{peers}{uc $self->server_name()} = { name => $self->server_name(), hops => 0, desc => $self->{config}{SERVERDESC}, }; $self->{state}{stats} = { maxconns => 0, maxlocal => 0, maxglobal => 0, ops_online => 0, invisible => 0, cmds => { }, }; return 1; } sub _state_delete { my $self = shift; delete $self->{state}; return 1; } sub _state_update_stats { my $self = shift; my $server = $self->server_name(); my $global = keys %{ $self->{state}{users} }; my $local = keys %{ $self->{state}{peers}{uc $server}{users} }; $self->{state}{stats}{maxglobal} = $global if $global > $self->{state}{stats}{maxglobal}; $self->{state}{stats}{maxlocal} = $local if $local > $self->{state}{stats}{maxlocal}; return 1; } sub _state_conn_stats { my $self = shift; $self->{state}{stats}{conns_cumlative}++; my $conns = keys %{ $self->{state}{conns} }; $self->{state}{stats}{maxconns} = $conns if $conns > $self->{state}{stats}{maxconns}; return 1; } sub _state_cmd_stat { my $self = shift; my $cmd = shift || return; my $line = shift || return; my $remote = shift; my $record = $self->{state}{stats}{cmds}{$cmd} || { remote => 0, local => 0, bytes => 0, }; $record->{local}++ if !$remote; $record->{remote}++ if $remote; $record->{bytes} += length $line; $self->{state}{stats}{cmds}{$cmd} = $record; return 1; } sub _state_find_user_host { my $self = shift; my $luser = shift || return; my $host = shift || '*'; my $local = $self->{state}{peers}{uc $self->server_name()}{users}; my @conns; for my $user (values %$local) { if (matches_mask($host, $user->{auth}{hostname}) && matches_mask($luser, $user->{auth}{ident})) { push @conns, [$user->{route_id}, $user->{nick}]; } } return @conns; } sub _state_local_users_match_rkline { my $self = shift; my $luser = shift || return; my $host = shift || return; my $local = $self->{state}{peers}{uc $self->server_name()}{users}; my @conns; for my $user (values %$local) { next if $user->{route_id} eq 'spoofed'; next if $user->{umode} && $user->{umode} =~ /o/; if (($user->{socket}[0] =~ /$host/ || $user->{auth}{hostname} =~ /$host/) && $user->{auth}{ident} =~ /$luser/) { push @conns, $user->{route_id}; } } return @conns; } sub _state_local_users_match_gline { my $self = shift; my $luser = shift || return; my $host = shift || return; my $local = $self->{state}{peers}{uc $self->server_name()}{users}; my @conns; if (my $netmask = Net::Netmask->new2($host)) { for my $user (values %$local) { next if $user->{route_id} eq 'spoofed'; next if $user->{umode} && $user->{umode} =~ /o/; if ($netmask->match($user->{socket}[0]) && matches_mask($luser, $user->{auth}{ident})) { push @conns, $user->{route_id}; } } } else { for my $user (values %$local) { next if $user->{route_id} eq 'spoofed'; next if $user->{umode} && $user->{umode} =~ /o/; if ((matches_mask($host, $user->{socket}[0]) || matches_mask($host, $user->{auth}{hostname})) && matches_mask($luser, $user->{auth}{ident})) { push @conns, $user->{route_id}; } } } return @conns; } sub _state_user_matches_rkline { my $self = shift; my $conn_id = shift || return; my $record = $self->{state}{conns}{$conn_id}; my $host = $record->{auth}{hostname} || $record->{socket}[0]; my $user = $record->{auth}{ident} || "~" . $record->{user}; my $ip = $record->{socket}[0]; for my $gline (@{ $self->{state}{rklines} }) { if (($host =~ /$gline->{host}/ || $ip =~ /$gline->{host}/) && $user =~ /$gline->{user}/) { return 1; } } return 0; } sub _state_user_matches_kline { my $self = shift; my $conn_id = shift || return; my $record = $self->{state}{conns}{$conn_id}; my $host = $record->{auth}{hostname} || $record->{socket}[0]; my $user = $record->{auth}{ident} || "~" . $record->{user}; my $ip = $record->{socket}[0]; for my $gline (@{ $self->{state}{klines} }) { if (my $netmask = Net::Netmask->new2($gline->{host})) { if ($netmask->match($ip) && matches_mask($gline->{user}, $user)) { return 1; } } elsif ((matches_mask($gline->{host}, $host) || matches_mask($gline->{host}, $ip)) && matches_mask($gline->{user}, $user)) { return 1; } } return 0; } sub _state_user_matches_gline { my $self = shift; my $conn_id = shift || return; my $record = $self->{state}{conns}{$conn_id}; my $host = $record->{auth}{hostname} || $record->{socket}[0]; my $user = $record->{auth}{ident} || "~" . $record->{user}; my $ip = $record->{socket}[0]; for my $gline (@{ $self->{state}{glines} }) { if (my $netmask = Net::Netmask->new2($gline->{host})) { if ($netmask->match($ip) && matches_mask($gline->{user}, $user)) { return 1; } elsif ((matches_mask($gline->{host}, $host) || matches_mask($gline->{host}, $ip)) && matches_mask($gline->{user}, $user)) { return 1; } } } return 0; } sub _state_auth_client_conn { my $self = shift; my $conn_id = shift || return; if (!$self->{config}{auth} || !@{ $self->{config}{auth} }) { return 1; } my $record = $self->{state}{conns}{$conn_id}; my $host = $record->{auth}{hostname} || $record->{socket}[0]; my $user = $record->{auth}{ident} || "~" . $record->{user}; my $uh = join '@', $user, $host; my $ui = join '@', $user, $record->{socket}[0]; for my $auth (@{ $self->{config}{auth} }) { if (matches_mask($auth->{mask}, $uh) || matches_mask($auth->{mask}, $ui)) { if ($auth->{password} && (!$record->{pass} || $auth->{password} ne $record->{pass})) { return 0; } $record->{auth}{hostname} = $auth->{spoof} if $auth->{spoof}; if (!$record->{auth}{ident} && $auth->{no_tilde}) { $record->{auth}{ident} = $record->{user}; } return 1; } } return 0; } sub _state_auth_peer_conn { my $self = shift; my ($conn_id, $name, $pass) = @_; if (!$conn_id || !$self->_connection_exists($conn_id)) { return; } return if !$name || !$pass; my $peers = $self->{config}{peers}; if (!$peers->{uc $name} || $peers->{uc $name}{pass} ne $pass) { return 0; } my $conn = $self->{state}{conns}{$conn_id}; if (!$peers->{uc $name}{ipmask} && $conn->{socket}[0] =~ /^127\./) { return 1; } return 0 if !$peers->{uc $name}{ipmask}; my $client_ip = $conn->{socket}[0]; if (ref $peers->{uc $name}{ipmask} eq 'ARRAY') { for my $block (grep { $_->isa('Net::Netmask') } @{ $peers->{uc $name}{ipmask} }) { return 1 if $block->match($client_ip); } } return 1 if matches_mask( '*!*@'.$peers->{uc $name}{ipmask}, "*!*\@$client_ip", ); return 0; } sub _state_send_credentials { my $self = shift; my $conn_id = shift || return; my $name = shift || return; return if !$self->_connection_exists($conn_id); return if !$self->{config}{peers}{uc $name}; my $peer = $self->{config}{peers}{uc $name}; $self->send_output( { command => 'PASS', params => [$peer->{rpass}, 'TS'], }, $conn_id, ); $self->send_output( { command => 'CAPAB', params => [ join (' ', @{ $self->{config}{capab} }, ($peer->{zip} ? 'ZIP' : ()) ), ], }, $conn_id, ); my $rec = $self->{state}{peers}{uc $self->server_name()}; $self->send_output( { command => 'SERVER', params => [$rec->{name}, $rec->{hops} + 1, $rec->{desc}], }, $conn_id, ); $self->send_output( { command => 'SVINFO', params => [5, 5, 0, time], }, $conn_id, ); $self->{state}{conns}{$conn_id}{zip} = $peer->{zip}; return 1; } sub _state_send_burst { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); my $server = $self->server_name(); my $conn = $self->{state}{conns}{$conn_id}; my $burst = grep { /^EOB$/i } @{ $conn->{capab} }; my $invex = grep { /^IE$/i } @{ $conn->{capab} }; my $excepts = grep { /^EX$/i } @{ $conn->{capab} }; my %map = qw(bans b excepts e invex I); my @lists = qw(bans); push @lists, 'excepts' if $excepts; push @lists, 'invex' if $invex; # Send SERVER burst for ($self->_state_server_burst($server, $conn->{name})) { $self->send_output($_, $conn_id ); } # Send NICK burst for my $nick (keys %{ $self->{state}{users} }) { my $record = $self->{state}{users}{$nick}; next if $record->{route_id} eq $conn_id; my $umode_fixed = $record->{umode}; $umode_fixed =~ s/[^aiow]//g; my $arrayref = [ $record->{nick}, $record->{hops} + 1, $record->{ts}, '+' . $umode_fixed, $record->{auth}{ident}, $record->{auth}{hostname}, $record->{server}, $record->{ircname}, ]; $self->send_output( { command => 'NICK', params => $arrayref, }, $conn_id, ); } # Send SJOIN+MODE burst for my $chan (keys %{ $self->{state}{chans} }) { next if $chan =~ /^\&/; my $chanrec = $self->{state}{chans}{$chan}; my @nicks = map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { my $w = $_; $w =~ tr/@%+/ABC/; [$w, $_] } $self->state_chan_list_prefixed($chan); my $arrayref2 = [ $chanrec->{ts}, $chanrec->{name}, '+' . $chanrec->{mode}, ($chanrec->{ckey} || ()), ($chanrec->{climit} || ()), join ' ', @nicks, ]; $self->send_output( { prefix => $server, command => 'SJOIN', params => $arrayref2, }, $conn_id, ); # TODO: MODE burst # Banlist|Exceptions|Invex my @output_modes; OUTER: for my $type (@lists) { my $length = length($server) + 4 + length($chan) + 4; my @buffer = ( '', '' ); INNER: for my $thing (keys %{ $chanrec->{$type} }) { $thing = $chanrec->{$type}{$thing}[0]; if (length(join ' ', @buffer, $thing)+$length+1 > 510) { $buffer[0] = '+' . $buffer[0]; push @output_modes, { prefix => $server, command => 'MODE', colonify => 0, params => [ $chanrec->{name}, $buffer[0], split /\s+/, $buffer[1], ], }; $buffer[0] = '+' . $map{$type}; $buffer[1] = $thing; next INNER; } if ($buffer[1]) { $buffer[0] .= $map{$type}; $buffer[1] = join ' ', $buffer[1], $thing; } else { $buffer[0] = '+' . $map{$type}; $buffer[1] = $thing; } } push @output_modes, { prefix => $server, command => 'MODE', colonify => 0, params => [ $chanrec->{name}, $buffer[0], split /\s+/, $buffer[1], ], } if $buffer[0]; } $self->send_output($_, $conn_id) for @output_modes; } $self->send_output( { prefix => $server, command => 'EOB', }, $conn_id, ) if $burst; return 1; } sub _state_server_burst { my $self = shift; my $peer = shift || return; my $targ = shift || return; if (!$self->state_peer_exists( $peer ) || !$self->state_peer_exists($targ)) { } my $ref = [ ]; $peer = $self->_state_peer_name($peer); my $upeer = uc $peer; my $utarg = uc $targ; for my $server (keys %{ $self->{state}{peers}{$upeer}{peers} }) { next if $server eq $utarg; my $rec = $self->{state}{peers}{$server}; push @$ref, { prefix => $peer, command => 'SERVER', params => [$rec->{name}, $rec->{hops} + 1, $rec->{desc}], }; push @$ref, $_ for $self->_state_server_burst($rec->{name}, $targ); } return @$ref if wantarray; return $ref; } sub _state_server_links { my $self = shift; my $peer = shift || return; my $orig = shift || return; my $nick = shift || return; return if !$self->state_peer_exists($peer); my $ref = [ ]; $peer = $self->_state_peer_name($peer); my $upeer = uc $peer; for my $server (keys %{ $self->{state}{peers}{$upeer}{peers} }) { my $rec = $self->{state}{peers}{$server}; for ($self->_state_server_links($rec->{name}, $orig, $nick)) { push @$ref, $_; } push @$ref, { prefix => $orig, command => '364', params => [ $nick, $rec->{name}, $peer, join( ' ', $rec->{hops}, $rec->{desc}), ], }; } return @$ref if wantarray; return $ref; } sub _state_peer_for_peer { my $self = shift; my $peer = shift || return; return if !$self->state_peer_exists($peer); $peer = uc $peer; return $self->{state}{peers}{$peer}{peer}; } sub _state_server_squit { my $self = shift; my $peer = shift || return; return if !$self->state_peer_exists($peer); my $ref = [ ]; my $upeer = uc $peer; push @$ref, $_ for keys %{ $self->{state}{peers}{$upeer}{users} }; for my $server (keys %{ $self->{state}{peers}{$upeer}{peers} }) { push @$ref, $_ for $self->_state_server_squit($server); } delete $self->{state}{peers}{$upeer}; delete $self->{state}{peers}{uc $self->server_name()}{peers}{$upeer}; return @$ref if wantarray; return $ref; } sub _state_register_peer { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); my $server = $self->server_name(); my $record = $self->{state}{conns}{$conn_id}; if (!$record->{cntr}) { $self->_state_send_credentials($conn_id, $record->{name}); } $record->{burst} = $record->{registered} = 1; $record->{type} = 'p'; $record->{route_id} = $conn_id; $record->{peer} = $server; $record->{users} = { }; $record->{peers} = { }; $self->{state}{peers}{uc $server}{peers}{uc $record->{name}} = $record; $self->{state}{peers}{ uc $record->{name} } = $record; $self->antiflood($conn_id, 0); $self->send_output( { prefix => $server, command => 'SERVER', params => [ $record->{name}, $record->{hops} + 1, $record->{desc}, ], }, grep { $_ ne $conn_id } $self->_state_connected_peers(), ); $self->send_event( "daemon_server", $record->{name}, $server, $record->{hops}, $record->{desc}, ); return 1; } sub _state_register_client { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); my $record = $self->{state}{conns}{$conn_id}; $record->{ts} = $record->{idle_time} = $record->{conn_time} = time; $record->{_ignore_i_umode} = 1; $record->{server} = $self->server_name(); $record->{hops} = 0; $record->{route_id} = $conn_id; $record->{umode} = ''; if (!$record->{auth}{ident}) { $record->{auth}{ident} = '~' . $record->{user}; } if ($record->{auth}{hostname} eq 'localhost' || !$record->{auth}{hostname} && $record->{socket}[0] =~ /^127\./) { $record->{auth}{hostname} = $self->server_name(); } if (!$record->{auth}{hostname}) { $record->{auth}{hostname} = $record->{socket}[0]; } $self->{state}{users}{uc_irc($record->{nick})} = $record; $self->{state}{peers}{uc $record->{server}}{users}{uc_irc($record->{nick})} = $record; my $arrayref = [ $record->{nick}, $record->{hops} + 1, $record->{ts}, '+i', $record->{auth}{ident}, $record->{auth}{hostname}, $record->{server}, $record->{ircname}, ]; delete $self->{state}{pending}{uc_irc($record->{nick})}; $self->send_output( { command => 'NICK', params => $arrayref, }, $self->_state_connected_peers(), ); $self->send_event("daemon_nick", @$arrayref); $self->_state_update_stats(); return 1; } sub state_nicks { my $self = shift; return map { $self->{state}{users}{$_}{nick} } keys %{ $self->{state}{users} }; } sub state_nick_exists { my $self = shift; my $nick = shift || return 1; $nick = uc_irc($nick); if (!defined $self->{state}{users}{$nick} && !defined $self->{state}{pending}{$nick}) { return 0; } return 1; } sub state_chans { my $self = shift; return map { $self->{state}{chans}{$_}{name} } keys %{ $self->{state}{chans} }; } sub state_chan_exists { my $self = shift; my $chan = shift || return; return 0 if !defined $self->{state}{chans}{uc_irc($chan)}; return 1; } sub state_peers { my $self = shift; return map { $self->{state}{peers}{$_}{name} } keys %{ $self->{state}{peers} }; } sub state_peer_exists { my $self = shift; my $peer = shift || return; return 0 if !defined $self->{state}{peers}{uc $peer}; return 1; } sub _state_peer_name { my $self = shift; my $peer = shift || return; return if !$self->state_peer_exists($peer); return $self->{state}{peers}{uc $peer}{name}; } sub _state_peer_desc { my $self = shift; my $peer = shift || return; return if !$self->state_peer_exists($peer); return $self->{state}{peers}{uc $peer}{desc}; } sub _state_peer_capab { my $self = shift; my $conn_id = shift || return; my $capab = shift || return; $capab = uc $capab; return if !$self->_connection_is_peer($conn_id); my $conn = $self->{state}{conns}{$conn_id}; return scalar grep { $_ eq $capab } @{ $conn->{capab} }; } sub state_user_full { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); my $record = $self->{state}{users}{uc_irc($nick)}; return $record->{nick} . '!' . $record->{auth}{ident} . '@' . $record->{auth}{hostname}; } sub state_user_nick { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); return $self->{state}{users}{uc_irc($nick)}{nick}; } sub _state_user_ip { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick) || !$self->_state_is_local_user($nick); my $record = $self->{state}{users}{uc_irc($nick)}; return $record->{socket}[0]; } sub _state_user_away { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); return 1 if defined $self->{state}{users}{uc_irc($nick)}{away}; return 0; } sub _state_user_away_msg { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); return $self->{state}{users}{uc_irc($nick)}{away}; } sub state_user_umode { my $self = shift; my $nick = shift || return; return if! $self->state_nick_exists($nick); return $self->{state}{users}{uc_irc($nick)}{umode}; } sub state_user_is_operator { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); return 0 if $self->{state}{users}{uc_irc($nick)}{umode} !~ /o/; return 1; } sub _state_user_is_deaf { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); return 0 if $self->{state}{users}{uc_irc($nick)}{umode} !~ /D/; return 1; } sub state_user_chans { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); my $record = $self->{state}{users}{uc_irc($nick)}; return map { $self->{state}{chans}{$_}{name} } keys %{ $record->{chans} }; } sub _state_user_route { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); my $record = $self->{state}{users}{uc_irc($nick)}; return $record->{route_id}; } sub state_user_server { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); my $record = $self->{state}{users}{uc_irc($nick)}; return $record->{server}; } sub _state_peer_route { my $self = shift; my $peer = shift || return; return if !$self->state_peer_exists($peer); my $record = $self->{state}{peers}{uc $peer}; return $record->{route_id}; } sub _state_connected_peers { my $self = shift; my $server = uc $self->server_name(); return if !keys %{ $self->{state}{peers} } > 1; my $record = $self->{state}{peers}{$server}; return map { $record->{peers}{$_}{route_id} } keys %{ $record->{peers} }; } sub state_chan_list { my $self = shift; my $chan = shift || return; my $status_msg = shift || ''; return if !$self->state_chan_exists($chan); $status_msg =~ s/[^@%+]//g; my $record = $self->{state}{chans}{uc_irc($chan)}; return map { $self->{state}{users}{$_}{nick} } keys %{ $record->{users} } if !$status_msg; my %map = qw(o 3 h 2 v 1); my %sym = qw(@ 3 % 2 + 1); my $lowest = (sort map { $sym{$_} } split //, $status_msg)[0]; return map { $self->{state}{users}{$_}{nick} } grep { $record->{users}{ $_ } and (reverse sort map { $map{$_} } split //, $record->{users}{$_})[0] >= $lowest } keys %{ $record->{users} }; } sub state_chan_list_prefixed { my $self = shift; my $chan = shift || return; return if !$self->state_chan_exists($chan); my $record = $self->{state}{chans}{uc_irc($chan)}; return map { my $n = $self->{state}{users}{$_}{nick}; my $m = $record->{users}{$_}; my $p = ''; $p = '@' if $m =~ /o/; $p = '%' if $m =~ /h/ && !$p; $p = '+' if $m =~ /v/ && !$p; $p . $n; } keys %{ $record->{users} }; } sub _state_chan_timestamp { my $self = shift; my $chan = shift || return; return if !$self->state_chan_exists($chan); return $self->{state}{chans}{uc_irc($chan)}{ts}; } sub state_chan_topic { my $self = shift; my $chan = shift || return; return if !$self->state_chan_exists($chan); my $record = $self->{state}{chans}{uc_irc($chan)}; return if !$record->{topic}; return [@{ $record->{topic} }]; } sub _state_is_local_user { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); my $record = $self->{state}{peers}{uc $self->server_name()}; return 1 if defined $record->{users}{uc_irc($nick)}; return 0; } sub _state_chan_name { my $self = shift; my $chan = shift || return; return if !$self->state_chan_exists($chan); return $self->{state}{chans}{uc_irc($chan)}{name}; } sub state_chan_mode_set { my $self = shift; my $chan = shift || return; my $mode = shift || return; return if !$self->state_chan_exists($chan); $mode =~ s/[^a-zA-Z]+//g; $mode = (split //, $mode )[0] if length $mode > 1; my $record = $self->{state}{chans}{uc_irc($chan)}; return 1 if $record->{mode} =~ /$mode/; return 0; } sub _state_user_invited { my $self = shift; my $nick = shift || return; my $chan = shift || return; return if !$self->state_nick_exists($nick); return 0 if !$self->state_chan_exists($chan); my $nickrec = $self->{state}{users}{uc_irc($nick)}; return 1 if $nickrec->{invites}{uc_irc($chan)}; # Check if user matches INVEX return 1 if $self->_state_user_matches_list($nick, $chan, 'invex'); return 0; } sub _state_user_banned { my $self = shift; my $nick = shift || return; my $chan = shift || return; return 0 if !$self->_state_user_matches_list($nick, $chan, 'bans'); return 1 if !$self->_state_user_matches_list($nick, $chan, 'excepts'); return 0; } sub _state_user_matches_list { my $self = shift; my $nick = shift || return; my $chan = shift || return; my $list = shift || 'bans'; return if !$self->state_nick_exists($nick); return 0 if !$self->state_chan_exists($chan); my $full = $self->state_user_full($nick); my $record = $self->{state}{chans}{uc_irc($chan)}; for my $mask (keys %{ $record->{$list} }) { return 1 if matches_mask($mask, $full); } return 0; } sub state_is_chan_member { my $self = shift; my $nick = shift || return; my $chan = shift || return; return if !$self->state_nick_exists($nick); return 0 if !$self->state_chan_exists($chan); my $record = $self->{state}{users}{uc_irc($nick)}; return 1 if defined $record->{chans}{uc_irc($chan)}; return 0; } sub state_user_chan_mode { my $self = shift; my $nick = shift || return; my $chan = shift || return; return if !$self->state_is_chan_member($nick, $chan); return $self->{state}{users}{uc_irc($nick)}{chans}{uc_irc($chan)}; } sub state_is_chan_op { my $self = shift; my $nick = shift || return; my $chan = shift || return; return if !$self->state_is_chan_member($nick, $chan); my $record = $self->{state}{users}{uc_irc($nick)}; return 1 if $record->{chans}{uc_irc($chan)} =~ /o/; return 1 if $self->{config}{OPHACKS} && $record->{umode} =~ /o/; return 0; } sub state_is_chan_hop { my $self = shift; my $nick = shift || return; my $chan = shift || return; return if !$self->state_is_chan_member($nick, $chan); my $record = $self->{state}{users}{uc_irc($nick)}; return 1 if $record->{chans}{uc_irc($chan)} =~ /h/; return 0; } sub state_has_chan_voice { my $self = shift; my $nick = shift || return; my $chan = shift || return; return if !$self->state_is_chan_member($nick, $chan); my $record = $self->{state}{users}{uc_irc($nick)}; return 1 if $record->{chans}{uc_irc($chan)} =~ /v/; return 0; } sub _state_o_line { my $self = shift; my $nick = shift || return; my ($user, $pass) = @_; return if !$self->state_nick_exists($nick); return if !$user || !$pass; my $ops = $self->{config}{ops}; return if !$ops->{$user}; return -1 if !chkpasswd ($pass, $ops->{$user}{password}); my $client_ip = $self->_state_user_ip($nick); return if !$client_ip; if (!$ops->{$user}{ipmask} && ($client_ip && $client_ip =~ /^127\./)) { return 1; } return 0 if !$ops->{$user}{ipmask}; if (ref $ops->{$user}{ipmask} eq 'ARRAY') { for my $block (grep { $_->isa('Net::Netmask') } @{ $ops->{$user}{ipmask} }) { return 1 if $block->match($client_ip); } } return 1 if matches_mask($ops->{$user}{ipmask}, $client_ip); return 0; } sub _state_users_share_chan { my $self = shift; my $nick1 = shift || return; my $nick2 = shift || return; return if !$self->state_nick_exists($nick1) || !$self->state_nick_exists($nick2); my $rec1 = $self->{state}{users}{uc_irc($nick1)}; my $rec2 = $self->{state}{users}{uc_irc($nick2)}; for my $chan (keys %{ $rec1->{chans} }) { return 1 if $rec2->{chans}{$chan}; } return 0; } sub _state_parse_msg_targets { my $self = shift; my $targets = shift || return; my %results; for my $target (split /,/, $targets) { if ($target =~ /^[#&]/) { $results{$target} = ['channel']; next; } if ($target =~ /^([@%+]+)([#&].+)$/ ) { $results{$target} = ['channel_ext', $1, $2]; next; } if ( $target =~ /^\${2}(.+)$/ ) { $results{$target} = ['servermask', $1]; next; } if ( $target =~ /^\$#(.+)$/ ) { $results{$target} = ['hostmask', $1]; next; } if ($target =~ /@/ ) { my ($nick, $server) = split /@/, $target, 2; my $host; ($nick, $host) = split ( /%/, $nick, 2 ) if $nick =~ /%/; $results{$target} = ['nick_ext', $nick, $server, $host]; next; } $results{$target} = ['nick']; } return \%results; } sub server_name { return $_[0]->server_config('ServerName'); } sub server_version { return $_[0]->server_config('Version'); } sub server_created { return strftime("This server was created %a %h %d %Y at %H:%M:%S %Z", localtime($_[0]->server_config('created'))); } sub _client_nickname { my $self = shift; my $wheel_id = $_[0] || return; return '*' if !$self->{state}{conns}{$wheel_id}{nick}; return $self->{state}{conns}{$wheel_id}{nick}; } sub _client_ip { my $self = shift; my $wheel_id = shift || return ''; return $self->{state}{conns}{$wheel_id}{socket}[0]; } sub server_config { my $self = shift; my $value = shift || return; return $self->{config}{uc $value}; } sub configure { my $self = shift; my $opts = ref $_[0] eq 'HASH' ? $_[0] : { @_ }; $opts->{uc $_} = delete $opts->{$_} for keys %$opts; my %defaults = ( CREATED => time(), CASEMAPPING => 'rfc1459', SERVERNAME => 'poco.server.irc', SERVERDESC => 'Poco? POCO? POCO!', VERSION => do { no strict 'vars'; ref($self) . '-' . (defined $VERSION ? $VERSION : 'dev-git'); }, NETWORK => 'poconet', HOSTLEN => 63, NICKLEN => 9, USERLEN => 10, REALLEN => 50, KICKLEN => 120, TOPICLEN => 80, AWAYLEN => 160, CHANNELLEN => 50, PASSWDLEN => 20, KEYLEN => 23, MAXCHANNELS => 15, MAXACCEPT => 20, MODES => 4, MAXTARGETS => 4, MAXBANS => 25, MAXBANLENGTH => 1024, AUTH => 1, ANTIFLOOD => 1, WHOISACTUALLY => 1, OPHACKS => 0, ); $self->{config}{$_} = $defaults{$_} for keys %defaults; for my $opt (qw(HOSTLEN NICKLEN USERLEN REALLEN TOPICLEN CHANNELLEN PASSWDLEN KEYLEN MAXCHANNELS MAXACCEPT MODES MAXTARGETS MAXBANS)) { my $new = delete $opts->{$opt}; if (defined $new && $new > $self->{config}{$opt}) { $self->{config}{$opt} = $new; } } for my $opt (qw(KICKLEN AWAYLEN)) { my $new = delete $opts->{$opt}; if (defined $new && $new < $self->{config}{$opt}) { $self->{config}{$opt} = $new; } } for my $opt (keys %$opts) { $self->{config}{$opt} = $opts->{$opt} if defined $opts->{$opt}; } $self->{config}{BANLEN} = sum(@{ $self->{config} }{qw(NICKLEN USERLEN HOSTLEN)}, 3); $self->{config}{USERHOST_REPLYLEN} = sum(@{ $self->{config} }{qw(NICKLEN USERLEN HOSTLEN)}, 5); $self->{config}{SERVERNAME} =~ s/[^a-zA-Z0-9\-.]//g; if ($self->{config}{SERVERNAME} !~ /\./) { $self->{config}{SERVERNAME} .= '.'; } if (!defined $self->{config}{ADMIN} || ref $self->{config}{ADMIN} ne 'ARRAY' || @{ $self->{config}{ADMIN} } != 3) { $self->{config}{ADMIN} = []; $self->{config}{ADMIN}[0] = 'Somewhere, Somewhere, Somewhere'; $self->{config}{ADMIN}[1] = 'Some Institution'; $self->{config}{ADMIN}[2] = 'someone@somewhere'; } if (!defined $self->{config}{INFO} || ref $self->{config}{INFO} ne 'ARRAY' || !@{ $self->{config}{INFO} } == 1) { $self->{config}{INFO} = [split /\n/, <<'EOF']; # POE::Component::Server::IRC # # Author: Chris "BinGOs" Williams # # Filter-IRCD Written by Hachi # # This module may be used, modified, and distributed under the same # terms as Perl itself. Please see the license that came with your Perl # distribution for details. # EOF } $self->{Error_Codes} = { 401 => [1, "No such nick/channel"], 402 => [1, "No such server"], 403 => [1, "No such channel"], 404 => [1, "Cannot send to channel"], 405 => [1, "You have joined too many channels"], 406 => [1, "There was no such nickname"], 407 => [1, "Too many targets"], 408 => [1, "No such service"], 409 => [1, "No origin specified"], 411 => [0, "No recipient given (%s)"], 412 => [0, "No text to send"], 413 => [1, "No toplevel domain specified"], 414 => [1, "Wildcard in toplevel domain"], 415 => [1, "Bad server/host mask"], 421 => [1, "Unknown command"], 422 => [0, "MOTD File is missing"], 423 => [1, "No administrative info available"], 424 => [1, "File error doing % on %"], 431 => [1, "No nickname given"], 432 => [1, "Erroneous nickname"], 433 => [1, "Nickname is already in use"], 436 => [1, "Nickname collision KILL from %s\@%s"], 437 => [1, "Nick/channel is temporarily unavailable"], 441 => [1, "They aren\'t on that channel"], 442 => [1, "You\'re not on that channel"], 443 => [2, "is already on channel"], 444 => [1, "User not logged in"], 445 => [0, "SUMMON has been disabled"], 446 => [0, "USERS has been disabled"], 451 => [0, "You have not registered"], 461 => [1, "Not enough parameters"], 462 => [0, "Unauthorised command (already registered)"], 463 => [0, "Your host isn\'t among the privileged"], 464 => [0, "Password mismatch"], 465 => [0, "You are banned from this server"], 466 => [0, "You will be banned from this server"], 467 => [1, "Channel key already set"], 471 => [1, "Cannot join channel (+l)"], 472 => [1, "is unknown mode char to me for %s"], 473 => [1, "Cannot join channel (+i)"], 474 => [1, "Cannot join channel (+b)"], 475 => [1, "Cannot join channel (+k)"], 476 => [1, "Bad Channel Mask"], 477 => [1, "Channel doesn\'t support modes"], 478 => [2, "Channel list is full"], 481 => [0, "Permission Denied- You\'re not an IRC operator"], 482 => [1, "You\'re not channel operator"], 483 => [0, "You can\'t kill a server!"], 484 => [0, "Your connection is restricted!"], 485 => [0, "You\'re not the original channel operator"], 491 => [0, "No O-lines for your host"], 501 => [0, "Unknown MODE flag"], 502 => [0, "Cannot change mode for other users"], }; $self->{config}{isupport} = { INVEX => undef, EXCEPT => undef, CALLERID => undef, CHANTYPES => '#&', PREFIX => '(ohv)@%+', CHANMODES => 'eIb,k,l,imnpst', STATUSMSG => '@%+', DEAF => 'D', MAXLIST => 'beI:' . $self->{config}{MAXBANS}, map { ($_, $self->{config}{$_}) } qw(MAXCHANNELS MAXTARGETS NICKLEN TOPICLEN KICKLEN CASEMAPPING NETWORK MODES AWAYLEN), }; $self->{config}{capab} = [qw(QS EX CHW IE HOPS UNKLN KLN GLN EOB)]; return 1; } sub _send_output_to_client { my $self = shift; my $wheel_id = shift || return 0; my $nick = $self->_client_nickname($wheel_id); $nick = shift if $self->_connection_is_peer($wheel_id); my $err = shift || return 0; return if !$self->_connection_exists($wheel_id); SWITCH: { if (ref $err eq 'HASH') { $self->send_output($err, $wheel_id); last SWITCH; } if (defined $self->{Error_Codes}{$err}) { my $input = { command => $err, prefix => $self->server_name(), params => [$nick], }; if ($self->{Error_Codes}{$err}[0] > 0) { for (my $i = 1; $i <= $self->{Error_Codes}{$err}[0]; $i++) { push @{ $input->{params} }, shift; } } if ($self->{Error_Codes}{$err}[1] =~ /%/) { push @{ $input->{params} }, sprintf($self->{Error_Codes}{$err}[1], @_); } else { push @{ $input->{params} }, $self->{Error_Codes}{$err}[1]; } $self->send_output($input, $wheel_id); } } return 1; } sub _send_output_to_channel { my $self = shift; my $channel = shift || return; my $output = shift || return; my $conn_id = shift || ''; return if !$self->state_chan_exists($channel); # Get conn_ids for each of our peers. my $ref = [ ]; my $peers = { }; $peers->{$_}++ for $self->_state_connected_peers(); delete $peers->{$conn_id} if $conn_id; push @$ref, $self->_state_user_route($_) for grep { $self->_state_is_local_user($_) } $self->state_chan_list($channel); @$ref = grep { $_ ne $conn_id } @$ref; if ($channel !~ /^\&/ && scalar keys %$peers && $output->{command} ne 'JOIN') { my $full = $output->{prefix}; my $nick = (split /!/, $full)[0]; my $output2 = { %$output }; $output2->{prefix} = $nick; $self->send_output($output2, keys %$peers); } $self->send_output($output, @$ref); $self->send_event( "daemon_" . lc $output->{command}, $output->{prefix}, @{ $output->{params} }, ); return 1; } sub add_operator { my $self = shift; my $ref; if (ref $_[0] eq 'HASH') { $ref = $_[0]; } else { $ref = { @_ }; } $ref->{lc $_} = delete $ref->{$_} for keys %$ref; if (!defined $ref->{username} || !defined $ref->{password}) { warn "Not enough parameters\n"; return; } my $record = $self->{state}{peers}{uc $self->server_name()}; my $user = delete $ref->{username}; $self->{config}{ops}{$user} = $ref; return 1; } sub del_operator { my $self = shift; my $user = shift || return; return if !defined $self->{config}{ops}{$user}; delete $self->{config}{ops}{$user}; return; } sub add_auth { my $self = shift; my $parms; if (ref $_[0] eq 'HASH') { $parms = $_[0]; } else { $parms = { @_ }; } $parms->{lc $_} = delete $parms->{$_} for keys %$parms; if (!$parms->{mask}) { warn "Not enough parameters specified\n"; return; } push @{ $self->{config}{auth} }, $parms; return 1; } sub del_auth { my $self = shift; my $mask = shift || return; my $i = 0; for (@{ $self->{config}{auth} }) { if ($_->{mask} eq $mask) { splice( @{ $self->{config}{auth} }, $i, 1 ); last; } ++$i; } return; } sub add_peer { my $self = shift; my $parms; if (ref $_[0] eq 'HASH') { $parms = $_[0]; } else { $parms = { @_ }; } $parms->{lc $_} = delete $parms->{$_} for keys %$parms; if (!defined $parms->{name} || !defined $parms->{pass} || !defined $parms->{rpass}) { croak((caller(0))[3].": Not enough parameters specified\n"); return; } $parms->{type} = 'c' if !$parms->{type} || lc $parms->{type} ne 'r'; $parms->{type} = lc $parms->{type}; $parms->{rport} = 6667 if $parms->{type} eq 'r' && !$parms->{rport}; for (qw(sockport sockaddr)) { $parms->{ $_ } = '*' if !$parms->{ $_ }; } $parms->{ipmask} = $parms->{raddress} if $parms->{raddress}; $parms->{zip} = 0 if !$parms->{zip}; my $name = $parms->{name}; $self->{config}{peers}{uc $name} = $parms; $self->add_connector( remoteaddress => $parms->{raddress}, remoteport => $parms->{rport}, name => $name, ) if $parms->{type} eq 'r' && $parms->{auto}; return 1; } sub del_peer { my $self = shift; my $name = shift || return; return if !defined $self->{config}{peers}{uc $name}; delete $self->{config}{peers}{uc $name}; return; } sub _terminate_conn_error { my $self = shift; my $conn_id = shift || return; my $msg = shift; return if !$self->_connection_exists($conn_id); $self->disconnect($conn_id, $msg); $self->send_output( { command => 'ERROR', params => [ 'Closing Link: ' . $self->_client_ip($conn_id) . ' (' . $msg . ')', ], }, $conn_id, ); while (my ($nick, $id) = each %{ $self->{state}{pending} }) { if ($id == $conn_id) { delete $self->{state}{pending}{$nick}; last; } } return 1; } sub daemon_server_kill { my $self = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count) { last SWITCH; } if ($self->state_peer_exists($args->[0])) { last SWITCH; } if (!$self->state_nick_exists($args->[0])) { last SWITCH; } my $target = $self->state_user_nick($args->[0]); my $comment = $args->[1] || ''; my $conn_id = ($args->[2] && $self->_connection_exists($args->[2]) ? $args->[2] : ''); if ($self->_state_is_local_user($target)) { my $route_id = $self->_state_user_route($target); $self->send_output( { prefix => $server, command => 'KILL', params => [$target, $comment], }, $route_id, ); $self->_terminate_conn_error( $route_id, "Killed ($server ($comment))", ); if ($route_id eq 'spoofed') { $self->call( 'del_spoofed_nick', $target, "Killed ($server ($comment))", ); } else { $self->{state}{conns}{$route_id}{killed} = 1; $self->_terminate_conn_error( $route_id, "Killed ($server ($comment))", ); } } else { $self->{state}{users}{uc_irc($target)}{killed} = 1; $self->send_output( { prefix => $server, command => 'KILL', params => [$target, "$server ($comment)"], }, grep { !$conn_id || $_ ne $conn_id } $self->_state_connected_peers(), ); $self->send_output( @{ $self->_daemon_peer_quit( $target, "Killed ($server ($comment))" ) }); } } return @$ref if wantarray; return $ref; } sub daemon_server_mode { my $self = shift; my $chan = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$self->state_chan_exists($chan)) { last SWITCH; } my $record = $self->{state}{chans}{uc_irc($chan)}; $chan = $record->{name}; my $full = $server; my $parsed_mode = parse_mode_line(@$args); while(my $mode = shift (@{ $parsed_mode->{modes} })) { my $arg; if ($mode =~ /^(\+[ohvklbIe]|-[ohvbIe])/) { $arg = shift @{ $parsed_mode->{args} }; } if (my ($flag, $char) = $mode =~ /^(\+|-)([ohv])/) { next if !$self->state_is_chan_member($arg, $chan); if ($flag eq '+' && $record->{users}{uc_irc($arg)} !~ /$char/) { # Update user and chan record $arg = uc_irc $arg; next if $mode eq '+h' && $record->{users}{$arg} =~ /o/; if ($char eq 'h' && $record->{users}{$arg} =~ /v/) { $record->{users}{$arg} =~ s/v//g; } if ($char eq 'o' && $record->{users}{$arg} =~ /h/) { $record->{users}{$arg} =~ s/h//g; } $record->{users}{$arg} = join('', sort split //, $record->{users}{$arg} . $char); $self->{state}{users}{$arg}{chans}{uc_irc($chan)} = $record->{users}{$arg}; } if ($flag eq '-' && $record->{users}{uc_irc($arg)} =~ /$char/) { # Update user and chan record $arg = uc_irc($arg); $record->{users}{$arg} =~ s/$char//g; $self->{state}{users}{$arg}{chans}{uc_irc($chan)} = $record->{users}{$arg}; } next; } if ($mode eq '+l' && $arg =~ /^\d+$/ && $arg > 0) { if ($record->{mode} !~ /l/) { $record->{mode} = join('', sort split //, $record->{mode} . 'l'); } $record->{climit} = $arg; next; } if ($mode eq '-l' && $record->{mode} =~ /l/) { $record->{mode} =~ s/l//g; delete $record->{climit}; next; } if ($mode eq '+k' && $arg) { if ($record->{mode} !~ /k/) { $record->{mode} = join('', sort split //, $record->{mode} . 'k'); } $record->{ckey} = $arg; next; } if ($mode eq '-k' && $record->{mode} =~ /k/) { $record->{mode} =~ s/k//g; delete $record->{ckey}; next; } # Bans if (my ($flag) = $mode =~ /(\+|-)b/) { my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{bans}{$umask}) { $record->{bans}{$umask} = [$mask, ($full || $server), time]; } if ($flag eq '-' and $record->{bans}{$umask}) { delete $record->{bans}{$umask}; } next; } # Invex if (my ($flag) = $mode =~ /(\+|-)I/) { my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{invex}{$umask}) { $record->{invex}{$umask} = [$mask, ($full || $server), time]; } if ($flag eq '-' && $record->{invex}{$umask}) { delete $record->{invex}{$umask}; } next; } # Exceptions if (my ($flag) = $mode =~ /(\+|-)e/) { my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{excepts}{$umask}) { $record->{excepts}{$umask} = [$mask, ($full || $server), time]; } if ($flag eq '-' && $record->{excepts}{$umask}) { delete $record->{excepts}{$umask}; } next; } # The rest should be argumentless. my ($flag, $char) = split //, $mode; if ($flag eq '+' && $record->{mode} !~ /$char/) { $record->{mode} = join('', sort split //, $record->{mode} . $char); next; } if ($flag eq '-' && $record->{mode} =~ /$char/) { $record->{mode} =~ s/$char//g; next; } } # while unshift @$args, $record->{name}; $self->send_output( { prefix => $server, command => 'MODE', params => $args, colonify => 0, }, $self->_state_connected_peers(), ); $self->send_output( { prefix => ($full || $server), command => 'MODE', params => $args, colonify => 0, }, map { $self->_state_user_route($_) } grep { $self->_state_is_local_user($_) } keys %{ $record->{users} }, ); $self->send_event("daemon_mode", $server, @$args); } # SWITCH return @$ref if wantarray; return $ref; } sub daemon_server_kick { my $self = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count || $count < 2) { last SWITCH; } my $chan = (split /,/, $args->[0])[0]; my $who = (split /,/, $args->[1])[0]; if (!$self->state_chan_exists($chan)) { last SWITCH; } $chan = $self->_state_chan_name($chan); if (!$self->state_nick_exists($who)) { last SWITCH; } $who = $self->state_user_nick($who); if (!$self->state_is_chan_member($who, $chan)) { last SWITCH; } my $comment = $args->[2] || $who; $self->_send_output_to_channel( $chan, { prefix => $server, command => 'KICK', params => [$chan, $who, $comment], }, ); $who = uc_irc($who); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$who}; delete $self->{state}{users}{$who}{chans}{$chan}; if (!keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub daemon_server_remove { my $self = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count || $count < 2) { last SWITCH; } my $chan = (split /,/, $args->[0])[0]; my $who = (split /,/, $args->[1])[0]; if (!$self->state_chan_exists($chan)) { last SWITCH; } $chan = $self->_state_chan_name($chan); if (!$self->state_nick_exists($who)) { last SWITCH; } my $fullwho = $self->state_user_full($who); $who = (split /!/, $who)[0]; if (!$self->state_is_chan_member($who, $chan)) { last SWITCH; } my $comment = 'Enforced PART'; $comment .= " \"$args->[2]\"" if $args->[2]; $self->_send_output_to_channel( $chan, { prefix => $fullwho, command => 'PART', params => [$chan, $comment], }, ); $who = uc_irc($who); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$who}; delete $self->{state}{users}{$who}{chans}{$chan}; if (!keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub daemon_server_wallops { my $self = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; if ($count) { $self->send_output( { prefix => $server, command => 'WALLOPS', params => [$args->[0]], }, $self->_state_connected_peers(), keys %{ $self->{state}{operwall} }, ); $self->send_event("daemon_wallops", $server, $args->[0]); } return @$ref if wantarray; return $ref; } sub add_spoofed_nick { my ($kernel, $self) = @_[KERNEL, OBJECT]; my $ref; if (ref $_[ARG0] eq 'HASH') { $ref = $_[ARG0]; } else { $ref = { @_[ARG0..$#_] }; } $ref->{ lc $_ } = delete $ref->{$_} for keys %$ref; return if !$ref->{nick}; return if $self->state_nick_exists($ref->{nick}); my $record = $ref; $record->{ts} = time if !$record->{ts}; $record->{type} = 's'; $record->{server} = $self->server_name(); $record->{hops} = 0; $record->{route_id} = 'spoofed'; $record->{umode} = 'i' if !$record->{umode}; if (!defined $record->{ircname}) { $record->{ircname} = "* I'm too lame to read the documentation *"; } $self->{state}{stats}{invisible}++ if $record->{umode} =~ /i/; $self->{state}{stats}{ops_online}++ if $record->{umode} =~ /o/; $record->{idle_time} = $record->{conn_time} = $record->{ts}; $record->{auth}{ident} = delete $record->{user} || $record->{nick}; $record->{auth}{hostname} = delete $record->{hostname} || $self->server_name(); $self->{state}{users}{uc_irc($record->{nick})} = $record; $self->{state}{peers}{uc $record->{server}}{users}{uc_irc($record->{nick})} = $record; my $arrayref = [ $record->{nick}, $record->{hops} + 1, $record->{ts}, '+' . $record->{umode}, $record->{auth}{ident}, $record->{auth}{hostname}, $record->{server}, $record->{ircname}, ]; $self->send_output( { command => 'NICK', params => $arrayref, }, $self->_state_connected_peers(), ); $self->send_event("daemon_nick", @$arrayref); $self->_state_update_stats(); return; } sub del_spoofed_nick { my ($kernel, $self, $nick) = @_[KERNEL, OBJECT, ARG0]; return if !$self->state_nick_exists($nick); return if $self->_state_user_route($nick) ne 'spoofed'; my $message = $_[ARG1] || 'Client Quit'; $self->send_output( @{ $self->_daemon_cmd_quit($nick, qq{"$message"}) }, qq{"$message"}, ); return; } sub _spoofed_command { my ($kernel, $self, $state, $nick) = @_[KERNEL, OBJECT, STATE, ARG0]; return if !$self->state_nick_exists($nick); return if $self->_state_user_route($nick) ne 'spoofed'; $nick = $self->state_user_nick($nick); $state =~ s/daemon_cmd_//; my $command = "_daemon_cmd_" . $state; if ($state =~ /^(privmsg|notice)$/) { my $type = uc $1; $self->_daemon_cmd_message($nick, $type, @_[ARG1 .. $#_]); return; } elsif ($state eq 'sjoin') { my $chan = $_[ARG1]; return if !$chan || !$self->state_chan_exists($chan); return if $self->state_is_chan_member($nick, $chan); $chan = $self->_state_chan_name($chan); my $ts = $self->_state_chan_timestamp($chan) - 10; $self->_daemon_peer_sjoin( 'spoofed', $self->server_name(), $ts, $chan, '+nt', '@' . $nick, ); return; } $self->$command($nick, @_[ARG1 .. $#_]) if $self->can($command); return; } 1; =encoding utf8 =head1 NAME POE::Component::Server::IRC - A fully event-driven networkable IRC server daemon module. =head1 SYNOPSIS # A fairly simple example: use strict; use warnings; use POE qw(Component::Server::IRC); my %config = ( servername => 'simple.poco.server.irc', nicklen => 15, network => 'SimpleNET' ); my $pocosi = POE::Component::Server::IRC->spawn( config => \%config ); POE::Session->create( package_states => [ 'main' => [qw(_start _default)], ], heap => { ircd => $pocosi }, ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{ircd}->yield('register', 'all'); # Anyone connecting from the loopback gets spoofed hostname $heap->{ircd}->add_auth( mask => '*@localhost', spoof => 'm33p.com', no_tilde => 1, ); # We have to add an auth as we have specified one above. $heap->{ircd}->add_auth(mask => '*@*'); # Start a listener on the 'standard' IRC port. $heap->{ircd}->add_listener(port => 6667); # Add an operator who can connect from localhost $heap->{ircd}->add_operator( { username => 'moo', password => 'fishdont', } ); } sub _default { my ($event, $args) = @_[ARG0 .. $#_]; print "$event: "; for my $arg (@$args) { if (ref($arg) eq 'ARRAY') { print "[", join ( ", ", @$arg ), "] "; } elsif (ref($arg) eq 'HASH') { print "{", join ( ", ", %$arg ), "} "; } else { print "'$arg' "; } } print "\n"; } =head1 DESCRIPTION POE::Component::Server::IRC is a POE component which implements an IRC server (also referred to as an IRC daemon or IRCd). It should be compliant with the pertient IRC RFCs and is based on reverse engineering Hybrid IRCd behaviour with regards to interactions with IRC clients and other IRC servers. Yes, that's right. POE::Component::Server::IRC is capable of linking to foreign IRC networks. It supports the TS5 server to server protocol and has been tested with linking to Hybrid-7 based networks. It should in theory work with any TS5-based IRC network. POE::Component::Server::IRC also has a services API, which enables one to extend the IRCd to create IRC Services. This is fully event-driven (of course =]). There is also a Plugin system, similar to that sported by L. B This is a subclass of L. You should read its documentation too. =head1 CONSTRUCTOR =head2 C Returns a new instance of the component. Takes the following parameters: =over 4 =item * B<'config'>, a hashref of configuration options, see the L|/configure> method for details. =back Any other parameters will be passed along to L's L|POE::Component::Server::IRC::Backend/create> method. If the component is spawned from within another session then that session will automagically be registered with the component to receive events and be sent an L|POE::Component::IRC::Server::Backend/ircd_registered> event. =head1 METHODS =head2 Information =head3 C No arguments, returns the name of the ircd. =head3 C No arguments, returns the software version of the ircd. =head3 C No arguments, returns a string signifying when the ircd was created. =head3 C Takes one argument, the server configuration value to query. =head2 Configuration These methods provide mechanisms for configuring and controlling the IRCd component. =head3 C Configures your new shiny IRCd. Takes a number of parameters: =over 4 =item * B<'servername'>, a name to bless your shiny new IRCd with, defaults to 'poco.server.irc'; =item * B<'serverdesc'>, a description for your IRCd, defaults to 'Poco? POCO? POCO!'; =item * B<'network'>, the name of the IRC network you will be creating, defaults to 'poconet'; =item * B<'nicklen'>, the max length of nicknames to support, defaults to 9. B: the nicklen must be the same on all servers on your IRC network; =item * B<'maxtargets'>, max number of targets a user can send PRIVMSG/NOTICE's to, defaults to 4; =item * B<'maxchannels'>, max number of channels users may join, defaults to 15; =item * B<'version'>, change the server version that is reported; =item * B<'admin'>, an arrayref consisting of the 3 lines that will be returned by ADMIN; =item * B<'info'>, an arrayref consisting of lines to be returned by INFO; =item * B<'ophacks'>, set to true to enable oper hacks. Default is false; =item * B<'whoisactually'>, setting this to a false value means that only opers can see 338. Defaults to true; =back =head3 C By default the IRCd allows any user to connect to the server without a password. Configuring auths enables you to control who can connect and set passwords required to connect. Takes the following parameters: =over 4 =item * B<'mask'>, a user@host or user@ipaddress mask to match against, mandatory; =item * B<'password'>, if specified, any client matching the mask must provide this to connect; =item * B<'spoof'>, if specified, any client matching the mask will have their hostname changed to this; =item * B<'no_tilde'>, if specified, the '~' prefix is removed from their username; =back Auth masks are processed in order of addition. If auth masks have been defined, then a connecting user *must* match one of the masks in order to be authorised to connect. This is a feature >;) =head3 C Takes a single argument, the mask to remove. =head3 C This adds an O line to the IRCd. Takes a number of parameters: =over 4 =item * B<'username'>, the username of the IRC oper, mandatory; =item * B<'password'>, the password, mandatory; =item * B<'ipmask'>, either a scalar ipmask or an arrayref of Net::Netmask objects; =back A scalar ipmask can contain '*' to match any number of characters or '?' to match one character. If no 'ipmask' is provided, operators are only allowed to OPER from the loopback interface. B<'password'> can be either plain-text, L|crypt>'d or unix/apache md5. See the C function in L for how to generate passwords. =head3 C Takes a single argument, the username to remove. =head3 C Adds peer servers that we will allow to connect to us and who we will connect to. Takes the following parameters: =over 4 =item * B<'name'>, the name of the server. This is the IRC name, not hostname, mandatory; =item * B<'pass'>, the password they must supply to us, mandatory; =item * B<'rpass'>, the password we need to supply to them, mandatory; =item * B<'type'>, the type of server, 'c' for a connecting server, 'r' for one that we will connect to; =item * B<'raddress'>, the remote address to connect to, implies 'type' eq 'r'; =item * B<'rport'>, the remote port to connect to, default is 6667; =item * B<'ipmask'>, either a scalar ipmask or an arrayref of Net::Netmask objects; =item * B<'auto'>, if set to true value will automatically connect to remote server if type is 'r'; =item * B<'zip'>, set to a true value to enable ziplink support. This must be done on both ends of the connection. Requires L; =back =head3 C Takes a single argument, the peer to remove. This does not disconnect the said peer if it is currently connected. =head2 State queries The following methods allow you to query state information regarding nicknames, channels, and peers. =head3 C Takes no arguments, returns a list of all nicknames in the state. =head3 C Takes no arguments, returns a list of all channels in the state. =head3 C Takes no arguments, returns a list of all irc servers in the state. =head3 C Takes one argument, a nickname, returns true or false dependent on whether the given nickname exists or not. =head3 C Takes one argument, a channel name, returns true or false dependent on whether the given channel exists or not. =head3 C Takes one argument, a peer server name, returns true or false dependent on whether the given peer exists or not. =head3 C Takes one argument, a nickname, returns that users full nick!user@host if they exist, undef if they don't. =head3 C Takes one argument, a nickname, returns the proper nickname for that user. Returns undef if the nick doesn't exist. =head3 C Takes one argument, a nickname, returns that users mode setting. =head3 C Takes one argument, a nickname, returns true or false dependent on whether the given nickname is an IRC operator or not. =head3 C Takes one argument, a nickname, returns a list of channels that that nick is a member of. =head3 C Takes one argument, a nickname, returns the name of the peer server that that user is connected from. =head3 C Takes one argument, a channel name, returns a list of the member nicks on that channel. =head3 C Takes one argument, a channel name, returns a list of the member nicks on that channel, nicknames will be prefixed with @%+ if they are +o +h or +v, respectively. =head3 C Takes one argument, a channel name, returns undef if no topic is set on that channel, or an arrayref consisting of the topic, who set it and the time they set it. =head3 C Takes two arguments, a channel name and a channel mode character. Returns true if that channel mode is set, false otherwise. =head3 C Takes two arguments, a nick and a channel name. Returns true if that nick is on channel, false otherwise. =head3 C Takes two arguments, a nick and a channel name. Returns that nicks status (+ohv or '') on that channel. =head3 C Takes two arguments, a nick and a channel name. Returns true if that nick is an channel operator, false otherwise. =head3 C Takes two arguments, a nick and a channel name. Returns true if that nick is an channel half-operator, false otherwise. =head3 C Takes two arguments, a nick and a channel name. Returns true if that nick has channel voice, false otherwise. =head2 Server actions =head3 C Takes two arguments, a nickname and a comment (which is optional); Issues a SERVER KILL of the given nick; =head3 C First argument is a channel name, remaining arguments are channel modes and their parameters to apply. =head3 C Takes two arguments that are mandatory and an optional one: channel name, nickname of the user to kick and a pithy comment. =head3 C Takes two arguments that are mandatory and an optional one: channel name, nickname of the user to remove and a pithy comment. =head3 C Takes one argument, the message text to send. =head1 INPUT EVENTS These are POE events that can be sent to the component. =head2 C Takes a single argument a hashref which should have the following keys: =over 4 =item * B<'nick'>, the nickname to add, mandatory; =item * B<'user'>, the ident you want the nick to have, defaults to the same as the nick; =item * B<'hostname'>, the hostname, defaults to the server name; =item * B<'umode'>, specify whether this is to be an IRCop etc, defaults to 'i'; =item * B<'ts'>, unixtime, default is time(), best not to meddle; =back B spoofed nicks are currently only really functional for use as IRC services. =head2 C Takes a single mandatory argument, the spoofed nickname to remove. Optionally, you may specify a quit message for the spoofed nick. =head2 Spoofed nick commands The following input events are for the benefit of spoofed nicks. All require a nickname of a spoofed nick as the first argument. =head3 C Takes two arguments, a spoofed nick and a channel name to join. =head3 C Takes two arguments, a spoofed nick and a channel name to part from. =head3 C Takes at least three arguments, a spoofed nick, a channel and a channel mode to apply. Additional arguments are parameters for the channel modes. =head3 C Takes at least three arguments, a spoofed nick, a channel name and the nickname of a user to kick from that channel. You may supply a fourth argument which will be the kick comment. =head3 C Takes three arguments, a spoofed nick, a channel name and the topic to set on that channel. If the third argument is an empty string then the channel topic will be unset. =head3 C Takes two arguments, a spoofed nick and a new nickname to change to. =head3 C Takes three arguments, a spoofed nick, a user@host mask to gline and a reason for the gline. =head3 C Takes a number of arguments depending on where the KLINE is to be applied and for how long: To set a permanent KLINE: $ircd->yield( 'daemon_cmd_kline', $spoofed_nick, $nick || $user_host_mask, $reason, ); To set a temporary 10 minute KLINE: $ircd->yield( 'daemon_cmd_kline', $spoofed_nick, 10, $nick || $user_host_mask, $reason, ); To set a temporary 10 minute KLINE on all servers: $ircd->yield( 'daemon_cmd_kline', $spoofed_nick, 10, $nick || $user_host_mask, 'on', '*', $reason, ); =head3 C Removes a KLINE as indicated by the user@host mask supplied. To remove a KLINE: $ircd->yield( 'daemon_cmd_unkline', $spoofed_nick, $user_host_mask, ); To remove a KLINE from all servers: $ircd->yield( 'daemon_cmd_unkline', $spoofed_nick, $user_host_mask, 'on', '*', ); =head3 C Used to set a regex based KLINE. The regex given must be based on a user@host mask. To set a permanent RKLINE: $ircd->yield( 'daemon_cmd_rkline', $spoofed_nick, '^.*$@^(yahoo|google|microsoft)\.com$', $reason, ); To set a temporary 10 minute RKLINE: $ircd->yield( 'daemon_cmd_rkline', $spoofed_nick, 10, '^.*$@^(yahoo|google|microsoft)\.com$', $reason, ); To set a temporary 10 minute RKLINE on all servers: $ircd->yield( 'daemon_cmd_kline', $spoofed_nick, 10, '^.*$@^(yahoo|google|microsoft)\.com$', 'on', '*', $reason, ); =head3 C Takes two arguments a spoofed nickname and an existing channel name. This command will then manipulate the channel timestamp to clear all modes on that channel, including existing channel operators, reset the channel mode to '+nt', the spoofed nick will then join the channel and gain channel ops. =head3 C Takes three arguments, a spoofed nickname, a target (which can be a nickname or a channel name) and whatever text you wish to send. =head3 C Takes three arguments, a spoofed nickname, a target (which can be a nickname or a channel name) and whatever text you wish to send. =head3 C Takes two arguments, a spoofed nickname and the text message to send to local operators. =head3 C Takes two arguments, a spoofed nickname and the text message to send to all operators. =head3 C Takes two arguments, a spoofed nickname and the text message to send to all operators. =head1 OUTPUT EVENTS =head2 C =over =item Emitted: when we fail to register with a peer; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, the server name; =item * C, the reason; =back =back =head2 C =over =item Emitted: when a server is introduced onto the network; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the server name; =item * C, the name of the server that is introducing them; =item * C, the hop count; =item * C, the server description; =back =back =head2 C =over =item Emitted: when a server quits the network; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the server name; =back =back =head2 C =over =item Emitted: when a user is introduced onto the network or changes their nickname =item Target: all plugins and registered sessions; =item Args (new user): =over 4 =item * C, the nickname; =item * C, the hop count; =item * C, the time stamp (TS); =item * C, the user mode; =item * C, the ident; =item * C, the hostname; =item * C, the server name; =item * C, the real name; =back =item Args (nick change): =over 4 =item * C, the full nick!user@host; =item * C, the new nickname; =back =back =head2 C =over =item Emitted: when a user changes their user mode; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the user mode change; =back =back =head2 C =over =item Emitted: when a user quits or the server they are on squits; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the quit message; =back =back =head2 C =over =item Emitted: when a user joins a channel =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the channel name; =back =back =head2 C =over =item Emitted: when a user parts a channel; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the channel name; =item * C, the part message; =back =back =head2 C =over =item Emitted: when a user is kicked from a channel; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the kicker; =item * C, the channel name; =item * C, the nick of the kicked user; =item * C, the kick message; =back =back =head2 C =over =item Emitted: when a channel mode is changed; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host or server name; =item * C, the channel name; =item * C, the modes and their arguments; =back =back =head2 C =over =item Emitted: when a channel topic is changed =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the changer; =item * C, the channel name; =item * C, the new topic; =back =back =head2 C =over =item Emitted: when a channel message is sent (a spoofed nick must be in the channel) =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the sender; =item * C, the channel name; =item * C, the message; =back =back =head2 C =over =item Emitted: when someone sends a private message to a spoofed nick =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the sender; =item * C, the spoofed nick targeted; =item * C, the message; =back =back =head2 C =over =item Emitted: when someone sends a notice to a spoofed nick or channel =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the sender; =item * C, the spoofed nick targeted or channel spoofed nick is in; =item * C, the message; =back =back =head2 C =over =item Emitted: when someone invites a spoofed nick to a channel; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the inviter; =item * C, the spoofed nick being invited; =item * C, the channel being invited to; =back =back =head2 C =over =item Emitted: when an oper issues a REHASH command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the oper; =back =back =head2 C =over =item Emitted: when an oper issues a DIE command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the oper; =back =back B the component will shutdown, this is a feature; =head2 C =over =item Emitted: when an oper issues a GLINE command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the user mask; =item * C, the host mask; =item * C, the reason; =back =back =head2 C =over =item Emitted: when an oper issues a KLINE command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the target for the KLINE; =item * C, the duration in seconds; =item * C, the user mask; =item * C, the host mask; =item * C, the reason; =back =back =head2 C =over =item Emitted: when an oper issues an RKLINE command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the target for the RKLINE; =item * C, the duration in seconds; =item * C, the user mask; =item * C, the host mask; =item * C, the reason; =back =back =head2 C =over =item Emitted: when an oper issues an UNKLINE command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the target for the UNKLINE; =item * C, the user mask; =item * C, the host mask; =back =back =head2 C =over =item Emitted: when an oper issues a LOCOPS command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the locops message; =back =back =head2 C =over =item Emitted: when an oper issues a WALLOPS or OPERWALL command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the wallops or operwall message; =back =back =head2 C =over =item Emitted: when a server issues a WALLOPS; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the server name; =item * C, the wallops message; =back =back =head1 BUGS A few have turned up in the past and they are sure to again. Please use L to report any. Alternatively, email the current maintainer. =head1 DEVELOPMENT You can find the latest source on github: L The project's developers usually hang out in the C<#poe> IRC channel on irc.perl.org. Do drop us a line. =head1 MAINTAINER Hinrik Ern SigurEsson =head1 AUTHOR Chris 'BinGOs' Williams =head1 LICENSE Copyright C<(c)> Chris Williams This module may be used, modified, and distributed under the same terms as Perl itself. Please see the license that came with your Perl distribution for details. =head1 KUDOS Rocco Caputo for creating POE. Buu for pestering me when I started to procrastinate =] =head1 SEE ALSO L L L L Hybrid IRCD L TSOra L RFC 2810 L RFC 2811 L RFC 2812 L RFC 2813 L =cut libpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/IRC/0000755000175000017500000000000012353530642023635 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/IRC/Test/0000755000175000017500000000000012353530642024554 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/inc/POE/Component/IRC/Test/Plugin.pm0000644000175000017500000000524412353530642026355 0ustar gregoagregoapackage POE::Component::IRC::Test::Plugin; use strict; use warnings FATAL => 'all'; use POE::Component::IRC::Plugin qw( :ALL ); sub new { return bless { @_[1..$#_] }, $_[0]; } sub PCI_register { $_[1]->plugin_register( $_[0], 'SERVER', qw(all) ); return 1; } sub PCI_unregister { return 1; } sub _default { return PCI_EAT_NONE; } 1; __END__ =head1 NAME POE::Component::IRC::Test::Plugin - Part of the L test-suite. =head1 SYNOPSIS use Test::More tests => 16; BEGIN { use_ok('POE::Component::IRC') }; BEGIN { use_ok('POE::Component::IRC::Test::Plugin') }; use POE; my $self = POE::Component::IRC->spawn( ); isa_ok ( $self, 'POE::Component::IRC' ); POE::Session->create( inline_states => { _start => \&test_start, }, package_states => [ main => [ qw(irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub test_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; $self->yield( 'register' => 'all' ); my $plugin = POE::Component::IRC::Test::Plugin->new(); isa_ok ( $plugin, 'POE::Component::IRC::Test::Plugin' ); $heap->{counter} = 6; if ( !$self->plugin_add( 'TestPlugin' => $plugin ) ) { fail( 'plugin_add' ); $self->yield( 'unregister' => 'all' ); $self->yield( 'shutdown' ); } return: } sub irc_plugin_add { my ($kernel, $heap, $desc, $plugin) = @_[KERNEL, HEAP, ARG0, ARG1]; isa_ok ( $plugin, 'POE::Component::IRC::Test::Plugin' ); if ( !$self->plugin_del( 'TestPlugin' ) ) { fail( 'plugin_del' ); $self->yield( 'unregister' => 'all' ); $self->yield( 'shutdown' ); } return; } sub irc_plugin_del { my ($kernel, $heap, $desc, $plugin) = @_[KERNEL, HEAP, ARG0, ARG1]; isa_ok ( $plugin, 'POE::Component::IRC::Test::Plugin' ); $heap->{counter}--; if ( $heap->{counter} <= 0 ) { $self->yield( 'unregister' => 'all' ); $self->yield( 'shutdown' ); } else { if ( !$self->plugin_add( 'TestPlugin' => $plugin ) ) { fail( 'plugin_add' ); $self->yield( 'unregister' => 'all' ); $self->yield( 'shutdown' ); } } return: } =head1 DESCRIPTION POE::Component::IRC::Test::Plugin is a very simple L plugin used to test that the plugin system is working correctly, as demonstrated in the L. =head1 CONSTRUCTOR =over =item C No arguments required, returns an POE::Component::IRC::Test::Plugin object. =back =head1 AUTHOR Chris "BinGOs" Williams =head1 SEE ALSO L =cut libpoe-component-irc-perl-6.88+dfsg.orig/t/01_base/0000755000175000017500000000000012354017166021276 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/t/01_base/04_pocosi.t0000644000175000017500000000067712353530642023272 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::Server::IRC; use Test::More tests => 2; my $ircd = POE::Component::Server::IRC->spawn(auth => 0); isa_ok($ircd, 'POE::Component::Server::IRC'); POE::Session->create( package_states => [ main => [ qw(_start) ] ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; pass('Session started'); $ircd->yield('shutdown'); } libpoe-component-irc-perl-6.88+dfsg.orig/t/01_base/01_compile.t0000644000175000017500000000207412353530642023414 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More; my @modules = qw( POE::Filter::IRC POE::Filter::IRC::Compat POE::Component::IRC POE::Component::IRC::State POE::Component::IRC::Qnet POE::Component::IRC::Qnet::State POE::Component::IRC::Constants POE::Component::IRC::Common POE::Component::IRC::Plugin POE::Component::IRC::Plugin::Whois POE::Component::IRC::Plugin::Proxy POE::Component::IRC::Plugin::PlugMan POE::Component::IRC::Plugin::NickServID POE::Component::IRC::Plugin::NickReclaim POE::Component::IRC::Plugin::Logger POE::Component::IRC::Plugin::ISupport POE::Component::IRC::Plugin::FollowTail POE::Component::IRC::Plugin::Console POE::Component::IRC::Plugin::Connector POE::Component::IRC::Plugin::CTCP POE::Component::IRC::Plugin::CycleEmpty POE::Component::IRC::Plugin::BotTraffic POE::Component::IRC::Plugin::BotAddressed POE::Component::IRC::Plugin::AutoJoin POE::Component::IRC::Plugin::BotCommand ); plan tests => scalar @modules; use_ok($_) for @modules; libpoe-component-irc-perl-6.88+dfsg.orig/t/01_base/02_filters.t0000644000175000017500000001365212353530642023441 0ustar gregoagregoause strict; use warnings FATAL => 'all'; use Test::More; use POE::Filter::Stackable; use POE::Filter::IRCD; use POE::Filter::IRC::Compat; use POE::Filter::IRC; my @tests = ( { line => ':joe!joe@example.com PART #foo :Goodbye', events => { part => [ 'joe!joe@example.com', '#foo', 'Goodbye', ], }, }, { line => ':joe!joe@example.com JOIN #foo', events => { join => [ 'joe!joe@example.com', '#foo', ], }, }, { line => ':magnet.shadowcat.co.uk 366 Flibble28185 #IRC.pm :End of /NAMES list.', events => { 366 => [ 'magnet.shadowcat.co.uk', '#IRC.pm :End of /NAMES list.', [ '#IRC.pm', 'End of /NAMES list.' ], ], }, }, { line => ':joe!joe@example.com PRIVMSG #foo :Fish go moo', events => { public => [ 'joe!joe@example.com', [ '#foo', ], 'Fish go moo', ], }, }, { line => ':joe!joe@example.com NOTICE #foo :Fish go moo', events => { notice => [ 'joe!joe@example.com', [ '#foo', ], 'Fish go moo', ], }, }, { line => ':joe!joe@example.com PRIVMSG foobar :Fish go moo', events => { msg => [ 'joe!joe@example.com', [ 'foobar', ], 'Fish go moo', ], }, }, { line => ':joe!joe@example.com NICK :moe', events => { nick => [ 'joe!joe@example.com', 'moe', ], }, }, { line => ':joe!joe@example.com QUIT :moe', events => { quit => [ 'joe!joe@example.com', 'moe', ], }, }, { line => 'PING :moe', events => { ping => [ 'moe' ], }, }, { line => ':joe!joe@example.com TOPIC #foo :Fish go moo', events => { topic => [ 'joe!joe@example.com', '#foo', 'Fish go moo', ], }, }, { line => ':joe!joe@example.com KICK #foo foobar :Goodbye', events => { kick => [ 'joe!joe@example.com', '#foo', 'foobar', 'Goodbye', ], }, }, { line => ':joe!joe@example.com INVITE foobar :#foo', events => { invite => [ 'joe!joe@example.com', '#foo', ], }, }, { line => ':joe!joe@example.com MODE #foo +m', events => { mode => [ 'joe!joe@example.com', '#foo', '+m', ], }, }, { line => ":joe!joe\@example.com PRIVMSG #foo :\001ACTION barfs on the floor.\001", events => { ctcp_action => [ 'joe!joe@example.com', [ '#foo', ], 'barfs on the floor.', ], }, }, { line => 'NOTICE * :Fish go moo', events => { snotice => [ 'Fish go moo', '*', ], }, }, { line => ':foo.bar.baz NOTICE * :Fish go moo', events => { snotice => [ 'Fish go moo', '*', 'foo.bar.baz', ], }, }, ); sub count { my (@items) = @_; my $count = 0; for my $item (@items) { $count++; next if ref $item ne 'ARRAY'; $count += count(@$item); } return $count; } my $sum; $sum += $_ for map { map { 4 + count( @$_ ) } values %{ $_->{events} } } @tests; plan tests => (2 + 2 * $sum); my $irc_filter = POE::Filter::IRC->new(); my $stack = POE::Filter::Stackable->new( Filters => [ POE::Filter::IRCD->new(), POE::Filter::IRC::Compat->new(), ]); for my $filter ( $stack, $irc_filter ) { isa_ok( $filter, 'POE::Filter::Stackable'); for my $test (@tests) { my @events = @{ $filter->get( [$test->{line}]) }; is(scalar @events, scalar keys %{ $test->{events} }, 'Event count'); for my $event (@events) { ok($test->{events}{$event->{name}}, "Got irc_$event->{name}"); is($event->{raw_line}, $test->{line}, "Raw Line $event->{name}"); my $test_args = $test->{events}{$event->{name}}; is(scalar @{ $event->{args} }, scalar @$test_args, "Args count $event->{name}"); for my $idx (0 .. $#$test_args) { if (ref $test_args->[$idx] eq 'ARRAY') { is( scalar @{ $event->{args}[$idx] }, scalar @{ $test_args->[$idx] }, "Sub args count $event->{name}", ); for my $iidx (0 .. $#{ $test_args->[$idx] }) { is( $event->{args}->[$idx][$iidx], $test_args->[$idx][$iidx], "Sub args Index $event->{name} $idx $iidx", ); } } else { is( $event->{args}[$idx], $test_args->[$idx], "Args Index $event->{name} $idx", ); } } } } } libpoe-component-irc-perl-6.88+dfsg.orig/lib/0000755000175000017500000000000012353530642020365 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/lib/POE/0000755000175000017500000000000012353530642021010 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/lib/POE/Filter/0000755000175000017500000000000012354017166022237 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/lib/POE/Filter/IRC/0000755000175000017500000000000012353530642022652 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/lib/POE/Filter/IRC/Compat.pm0000644000175000017500000003612012353530642024435 0ustar gregoagregoapackage POE::Filter::IRC::Compat; BEGIN { $POE::Filter::IRC::Compat::AUTHORITY = 'cpan:HINRIK'; } $POE::Filter::IRC::Compat::VERSION = '6.88'; use strict; use warnings FATAL => 'all'; use Carp; use POE::Filter::IRCD; use File::Basename qw(fileparse); use base qw(POE::Filter); my %irc_cmds = ( qr/^\d{3}$/ => sub { my ($self, $event, $line) = @_; $event->{args}->[0] = _decolon( $line->{prefix} ); shift @{ $line->{params} }; if ( $line->{params}->[0] && $line->{params}->[0] =~ /\x20/ ) { $event->{args}->[1] = $line->{params}->[0]; } else { $event->{args}->[1] = join(' ', ( map { /\x20/ ? ":$_" : $_ } @{ $line->{params} } ) ); } $event->{args}->[2] = $line->{params}; }, qr/^cap$/ => sub { my ($self, $event, $line) = @_; for (my $i = 0; ; $i++) { last if !defined $line->{params}[$i+1]; $event->{args}[$i] = $line->{params}[$i+1]; } }, qr/^notice$/ => sub { my ($self, $event, $line) = @_; if (defined $line->{prefix} && $line->{prefix} =~ /!/) { $event->{args} = [ _decolon( $line->{prefix} ), [split /,/, $line->{params}->[0]], ($self->{identifymsg} ? _split_idmsg($line->{params}->[1]) : $line->{params}->[1] ), ]; } else { $event->{name} = 'snotice'; $event->{args} = [ $line->{params}->[1], $line->{params}->[0], (defined $line->{prefix} ? _decolon($line->{prefix}) : ()), ]; } }, qr/^privmsg$/ => sub { my ($self, $event, $line) = @_; if ( grep { index( $line->{params}->[0], $_ ) >= 0 } @{ $self->{chantypes} } ) { $event->{args} = [ _decolon( $line->{prefix} ), [split /,/, $line->{params}->[0]], ($self->{identifymsg} ? _split_idmsg($line->{params}->[1]) : $line->{params}->[1] ), ]; $event->{name} = 'public'; } else { $event->{args} = [ _decolon( $line->{prefix} ), [split /,/, $line->{params}->[0]], ($self->{identifymsg} ? _split_idmsg($line->{params}->[1]) : $line->{params}->[1] ), ]; $event->{name} = 'msg'; } }, qr/^invite$/ => sub { my ($self, $event, $line) = @_; shift( @{ $line->{params} } ); unshift( @{ $line->{params} }, _decolon( $line->{prefix} || '' ) ) if $line->{prefix}; $event->{args} = $line->{params}; }, ); # the magic cookie jar my %dcc_types = ( qr/^(?:CHAT|SEND)$/ => sub { my ($nick, $type, $args) = @_; my ($file, $addr, $port, $size); return if !(($file, $addr, $port, $size) = $args =~ /^(".+"|[^ ]+) +(\d+) +(\d+)(?: +(\d+))?/); if ($file =~ s/^"//) { $file =~ s/"$//; $file =~ s/\\"/"/g; } $file = fileparse($file); return ( $port, { nick => $nick, type => $type, file => $file, size => $size, addr => $addr, port => $port, }, $file, $size, $addr, ); }, qr/^(?:ACCEPT|RESUME)$/ => sub { my ($nick, $type, $args) = @_; my ($file, $port, $position); return if !(($file, $port, $position) = $args =~ /^(".+"|[^ ]+) +(\d+) +(\d+)/); $file =~ s/^"|"$//g; $file = fileparse($file); return ( $port, { nick => $nick, type => $type, file => $file, size => $position, port => $port, }, $file, $position, ); }, ); sub new { my ($package, %self) = @_; $self{lc $_} = delete $self{$_} for keys %self; $self{BUFFER} = [ ]; $self{_ircd} = POE::Filter::IRCD->new(); $self{chantypes} = [ '#', '&' ] if ref $self{chantypes} ne 'ARRAY'; return bless \%self, $package; } sub clone { my $self = shift; my $nself = { }; $nself->{$_} = $self->{$_} for keys %{ $self }; $nself->{BUFFER} = [ ]; return bless $nself, ref $self; } # Set/clear the 'debug' flag. sub debug { my ($self, $flag) = @_; if (defined $flag) { $self->{debug} = $flag; $self->{_ircd}->debug($flag); } return $self->{debug}; } sub chantypes { my ($self, $ref) = @_; return if ref $ref ne 'ARRAY' || !@{ $ref }; $self->{chantypes} = $ref; return 1; } sub identifymsg { my ($self, $switch) = @_; $self->{identifymsg} = $switch; return; } sub _split_idmsg { my ($line) = @_; my ($identified, $msg) = split //, $line, 2; $identified = $identified eq '+' ? 1 : 0; return $msg, $identified; } sub get_one { my ($self) = @_; my $line = shift @{ $self->{BUFFER} } or return [ ]; if (ref $line ne 'HASH' || !$line->{command} || !$line->{params}) { warn "Received line '$line' that is not IRC protocol\n" if $self->{debug}; return [ ]; } if ($line->{command} =~ /^PRIVMSG|NOTICE$/ && $line->{params}->[1] =~ tr/\001//) { return $self->_get_ctcp($line); } my $event = { name => lc $line->{command}, raw_line => $line->{raw_line}, }; for my $cmd (keys %irc_cmds) { if ($event->{name} =~ $cmd) { $irc_cmds{$cmd}->($self, $event, $line); return [ $event ]; } } # default unshift( @{ $line->{params} }, _decolon( $line->{prefix} || '' ) ) if $line->{prefix}; $event->{args} = $line->{params}; return [ $event ]; } sub get_one_start { my ($self, $lines) = @_; push @{ $self->{BUFFER} }, @$lines; return; } sub put { my ($self, $lineref) = @_; my $quoted = [ ]; push @$quoted, _ctcp_quote($_) for @$lineref; return $quoted; } # Properly CTCP-quotes a message. Whoop. sub _ctcp_quote { my ($line) = @_; $line = _low_quote( $line ); #$line =~ s/\\/\\\\/g; $line =~ s/\001/\\a/g; return "\001$line\001"; } # Splits a message into CTCP and text chunks. This is gross. Most of # this is also stolen from Net::IRC, but I (fimm) wrote that too, so it's # used with permission. ;-) sub _ctcp_dequote { my ($msg) = @_; my (@chunks, $ctcp, $text); # CHUNG! CHUNG! CHUNG! if (!defined $msg) { croak 'Not enough arguments to POE::Filter::IRC::Compat::_ctcp_dequote'; } # Strip out any low-level quoting in the text. $msg = _low_dequote( $msg ); # Filter misplaced \001s before processing... (Thanks, tchrist!) substr($msg, rindex($msg, "\001"), 1, '\\a') if ($msg =~ tr/\001//) % 2 != 0; return if $msg !~ tr/\001//; @chunks = split /\001/, $msg; shift @chunks if !length $chunks[0]; # FIXME: Is this safe? for (@chunks) { # Dequote unnecessarily quoted chars, and convert escaped \'s and ^A's. s/\\([^\\a])/$1/g; s/\\\\/\\/g; s/\\a/\001/g; } # If the line begins with a control-A, the first chunk is a CTCP # message. Otherwise, it starts with text and alternates with CTCP # messages. Really stupid protocol. if ($msg =~ /^\001/) { push @$ctcp, shift @chunks; } while (@chunks) { push @$text, shift @chunks; push @$ctcp, shift @chunks if @chunks; } return ($ctcp, $text); } sub _decolon { my ($line) = @_; $line =~ s/^://; return $line; } ## no critic (Subroutines::ProhibitExcessComplexity) sub _get_ctcp { my ($self, $line) = @_; # Is this a CTCP request or reply? my $ctcp_type = $line->{command} eq 'PRIVMSG' ? 'ctcp' : 'ctcpreply'; # CAPAP IDENTIFY-MSG is only applied to ACTIONs my ($msg, $identified) = ($line->{params}->[1], undef); ($msg, $identified) = _split_idmsg($msg) if $self->{identifymsg} && $msg =~ /^.ACTION/; my $events = [ ]; my ($ctcp, $text) = _ctcp_dequote($msg); if (!defined $ctcp) { warn "Received malformed CTCP message: $msg\n" if $self->{debug}; return $events; } my $nick = defined $line->{prefix} ? (split /!/, $line->{prefix})[0] : undef; # We only process the first CTCP. The only people who send multiple ones # are those who are trying to flood our outgoing queue anyway (e.g. by # having us reply to 20 VERSION requests at a time). my ($name, $args); CTCP: for my $string ($ctcp->[0]) { if (!(($name, $args) = $string =~ /^(\w+)(?: +(.*))?/)) { defined $nick ? do { warn "Received malformed CTCP message from $nick: $string\n" if $self->{debug} } : do { warn "Trying to send malformed CTCP message: $string\n" if $self->{debug} } ; last CTCP; } if (lc $name eq 'dcc') { my ($dcc_type, $rest); if (!(($dcc_type, $rest) = $args =~ /^(\w+) +(.+)/)) { defined $nick ? do { warn "Received malformed DCC request from $nick: $args\n" if $self->{debug} } : do { warn "Trying to send malformed DCC request: $args\n" if $self->{debug} } ; last CTCP; } $dcc_type = uc $dcc_type; my ($handler) = grep { $dcc_type =~ /$_/ } keys %dcc_types; if (!$handler) { warn "Unhandled DCC $dcc_type request: $rest\n" if $self->{debug}; last CTCP; } my @dcc_args = $dcc_types{$handler}->($nick, $dcc_type, $rest); if (!@dcc_args) { defined $nick ? do { warn "Received malformed DCC $dcc_type request from $nick: $rest\n" if $self->{debug} } : do { warn "Trying to send malformed DCC $dcc_type request: $rest\n" if $self->{debug} } ; last CTCP; } push @$events, { name => 'dcc_request', args => [ $line->{prefix}, $dcc_type, @dcc_args, ], raw_line => $line->{raw_line}, }; } else { push @$events, { name => $ctcp_type . '_' . lc $name, args => [ $line->{prefix}, [split /,/, $line->{params}->[0]], (defined $args ? $args : ''), (defined $identified ? $identified : () ), ], raw_line => $line->{raw_line}, }; } } # XXX: I'm not quite sure what this is for, but on FreeNode it adds an # extra bogus event and displays a debug message, so I have disabled it. # FreeNode precedes PRIVMSG and CTCP ACTION messages with '+' or '-'. #if ($text && @$text) { # my $what; # ($what) = $line->{raw_line} =~ /^(:[^ ]+ +\w+ +[^ ]+ +)/ # or warn "What the heck? '".$line->{raw_line}."'\n" if $self->{debug}; # $text = (defined $what ? $what : '') . ':' . join '', @$text; # $text =~ s/\cP/^P/g; # warn "CTCP: $text\n" if $self->{debug}; # push @$events, @{ $self->{_ircd}->get([$text]) }; #} return $events; } # Quotes a string in a low-level, protocol-safe, utterly brain-dead # fashion. Returns the quoted string. sub _low_quote { my ($line) = @_; my %enquote = ("\012" => 'n', "\015" => 'r', "\0" => '0', "\cP" => "\cP"); if (!defined $line) { croak 'Not enough arguments to POE::Filter::IRC::Compat->_low_quote'; } if ($line =~ tr/[\012\015\0\cP]//) { # quote \n, \r, ^P, and \0. $line =~ s/([\012\015\0\cP])/\cP$enquote{$1}/g; } return $line; } # Does low-level dequoting on CTCP messages. I hate this protocol. # Yes, I copied this whole section out of Net::IRC. sub _low_dequote { my ($line) = @_; my %dequote = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP"); if (!defined $line) { croak 'Not enough arguments to POE::Filter::IRC::Compat->_low_dequote'; } # dequote \n, \r, ^P, and \0. # Thanks to Abigail (abigail@foad.org) for this clever bit. if ($line =~ tr/\cP//) { $line =~ s/\cP([nr0\cP])/$dequote{$1}/g; } return $line; } 1; =encoding utf8 =head1 NAME POE::Filter::IRC::Compat - A filter which converts L output into L events =head1 SYNOPSIS my $filter = POE::Filter::IRC::Compat->new(); my @events = @{ $filter->get( [ @lines ] ) }; my @msgs = @{ $filter->put( [ @messages ] ) }; =head1 DESCRIPTION POE::Filter::IRC::Compat is a L that converts L output into the L compatible event references. Basically a hack, so I could replace L with something that was more generic. Among other things, it converts normal text into thoroughly CTCP-quoted messages, and transmogrifies CTCP-quoted messages into their normal, sane components. Rather what you'd expect a filter to do. A note: the CTCP protocol sucks bollocks. If I ever meet the fellow who came up with it, I'll shave their head and tattoo obscenities on it. Just read the "specification" (F in this distribution) and you'll hopefully see what I mean. Quote this, quote that, quote this again, all in different and weird ways... and who the hell needs to send mixed CTCP and text messages? WTF? It looks like it's practically complexity for complexity's sake -- and don't even get me started on the design of the DCC protocol! Anyhow, enough ranting. Onto the rest of the docs... =head1 METHODS =head2 C Returns a POE::Filter::IRC::Compat object. Takes no arguments. =head2 C Makes a copy of the filter, and clears the copy's buffer. =head2 C Takes an arrayref of L hashrefs and produces an arrayref of L compatible event hashrefs. Yay. =head2 C, C These perform a similar function as C but enable the filter to work with L. =head2 C Takes an array reference of CTCP messages to be properly quoted. This doesn't support CTCPs embedded in normal messages, which is a brain-dead hack in the protocol, so do it yourself if you really need it. Returns an array reference of the quoted lines for sending. =head2 C Takes an optinal true/false value which enables/disables debugging accordingly. Returns the debug status. =head2 C Takes an arrayref of possible channel prefix indicators. =head2 C Takes a boolean to turn on/off the support for CAPAB IDENTIFY-MSG. =head1 AUTHOR Chris 'BinGOs' Williams =head1 SEE ALSO L L L =cut libpoe-component-irc-perl-6.88+dfsg.orig/lib/POE/Filter/IRC.pm0000644000175000017500000000355112353530642023214 0ustar gregoagregoapackage POE::Filter::IRC; BEGIN { $POE::Filter::IRC::AUTHORITY = 'cpan:HINRIK'; } $POE::Filter::IRC::VERSION = '6.88'; use strict; use warnings FATAL => 'all'; use POE::Filter::Stackable; use POE::Filter::IRCD; use POE::Filter::IRC::Compat; sub new { my ($package, %opts) = @_; $opts{lc $_} = delete $opts{$_} for keys %opts; return POE::Filter::Stackable->new( Filters => [ POE::Filter::IRCD->new( DEBUG => $opts{debug} ), POE::Filter::IRC::Compat->new( DEBUG => $opts{debug} ), ], ); } 1; =encoding utf8 =head1 NAME POE::Filter::IRC -- A POE-based parser for the IRC protocol =head1 SYNOPSIS my $filter = POE::Filter::IRC->new(); my @events = @{ $filter->get( [ @lines ] ) }; =head1 DESCRIPTION POE::Filter::IRC takes lines of raw IRC input and turns them into weird little data structures, suitable for feeding to L. They look like this: { name => 'event name', args => [ some info about the event ] } This module was long deprecated in L. It now uses the same mechanism that that uses to parse IRC text. =head1 CONSTRUCTOR =head2 C Returns a new L object containing a L object and a L object. This does the same job that POE::Filter::IRC used to do. =head1 METHODS See the documentation for POE::Filter::IRCD and POE::Filter::IRC::Compat. =head1 AUTHOR Dennis C Taylor Refactoring by Chris C Williams =head1 SEE ALSO The documentation for L and L. L L L =cut libpoe-component-irc-perl-6.88+dfsg.orig/lib/POE/Component/0000755000175000017500000000000012353530642022752 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/lib/POE/Component/IRC/0000755000175000017500000000000012353530642023367 5ustar gregoagregoalibpoe-component-irc-perl-6.88+dfsg.orig/lib/POE/Component/IRC/State.pm0000644000175000017500000015166212353530642025020 0ustar gregoagregoapackage POE::Component::IRC::State; BEGIN { $POE::Component::IRC::State::AUTHORITY = 'cpan:HINRIK'; } $POE::Component::IRC::State::VERSION = '6.88'; use strict; use warnings FATAL => 'all'; use IRC::Utils qw(uc_irc parse_mode_line normalize_mask); use POE; use POE::Component::IRC::Plugin qw(PCI_EAT_NONE); use base qw(POE::Component::IRC); # Event handlers for tracking the STATE. $self->{STATE} is used as our # namespace. uc_irc() is used to create unique keys. # RPL_WELCOME # Make sure we have a clean STATE when we first join the network and if we # inadvertently get disconnected. sub S_001 { my $self = shift; $self->SUPER::S_001(@_); shift @_; delete $self->{STATE}; delete $self->{NETSPLIT}; $self->{STATE}{usermode} = ''; $self->yield(mode => $self->nick_name()); return PCI_EAT_NONE; } sub S_disconnected { my $self = shift; $self->SUPER::S_disconnected(@_); shift @_; my $nickinfo = $self->nick_info($self->nick_name()); $nickinfo = {} if !defined $nickinfo; my $channels = $self->channels(); push @{ $_[-1] }, $nickinfo, $channels; return PCI_EAT_NONE; } sub S_error { my $self = shift; $self->SUPER::S_error(@_); shift @_; my $nickinfo = $self->nick_info($self->nick_name()); $nickinfo = {} if !defined $nickinfo; my $channels = $self->channels(); push @{ $_[-1] }, $nickinfo, $channels; return PCI_EAT_NONE; } sub S_socketerr { my ($self, undef) = splice @_, 0, 2; my $nickinfo = $self->nick_info($self->nick_name()); $nickinfo = {} if !defined $nickinfo; my $channels = $self->channels(); push @{ $_[-1] }, $nickinfo, $channels; return PCI_EAT_NONE; } sub S_join { my ($self, undef) = splice @_, 0, 2; my ($nick, $user, $host) = split /[!@]/, ${ $_[0] }; my $map = $self->isupport('CASEMAPPING'); my $chan = ${ $_[1] }; my $uchan = uc_irc($chan, $map); my $unick = uc_irc($nick, $map); if ($unick eq uc_irc($self->nick_name(), $map)) { delete $self->{STATE}{Chans}{ $uchan }; $self->{CHANNEL_SYNCH}{ $uchan } = { MODE => 0, WHO => 0, BAN => 0, _time => time(), }; $self->{STATE}{Chans}{ $uchan } = { Name => $chan, Mode => '' }; # fake a WHO sync if we're only interested in people's user@host # and the server provides those in the NAMES reply if (exists $self->{whojoiners} && !$self->{whojoiners} && $self->isupport('UHNAMES')) { $self->_channel_sync($chan, 'WHO'); } else { $self->yield(who => $chan); } $self->yield(mode => $chan); $self->yield(mode => $chan => 'b'); } else { SWITCH: { my $netsplit = "$unick!$user\@$host"; if ( exists $self->{NETSPLIT}{Users}{ $netsplit } ) { # restore state from NETSPLIT if it hasn't expired. my $nuser = delete $self->{NETSPLIT}{Users}{ $netsplit }; if ( ( time - $nuser->{stamp} ) < ( 60 * 60 ) ) { $self->{STATE}{Nicks}{ $unick } = $nuser->{meta}; $self->send_event_next(irc_nick_sync => $nick, $chan); last SWITCH; } } if ( (!exists $self->{whojoiners} || $self->{whojoiners}) && !exists $self->{STATE}{Nicks}{ $unick }{Real}) { $self->yield(who => $nick); push @{ $self->{NICK_SYNCH}{ $unick } }, $chan; } else { # Fake 'irc_nick_sync' $self->send_event_next(irc_nick_sync => $nick, $chan); } } } $self->{STATE}{Nicks}{ $unick }{Nick} = $nick; $self->{STATE}{Nicks}{ $unick }{User} = $user; $self->{STATE}{Nicks}{ $unick }{Host} = $host; $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan } = ''; $self->{STATE}{Chans}{ $uchan }{Nicks}{ $unick } = ''; return PCI_EAT_NONE; } sub S_chan_sync { my ($self, undef) = splice @_, 0, 2; my $chan = ${ $_[0] }; if ($self->{awaypoll}) { $poe_kernel->state(_away_sync => $self); $poe_kernel->delay_add(_away_sync => $self->{awaypoll} => $chan); } return PCI_EAT_NONE; } sub S_part { my ($self, undef) = splice @_, 0, 2; my $map = $self->isupport('CASEMAPPING'); my $nick = uc_irc((split /!/, ${ $_[0] } )[0], $map); my $uchan = uc_irc(${ $_[1] }, $map); if ($nick eq uc_irc($self->nick_name(), $map)) { delete $self->{STATE}{Nicks}{ $nick }{CHANS}{ $uchan }; delete $self->{STATE}{Chans}{ $uchan }{Nicks}{ $nick }; for my $member ( keys %{ $self->{STATE}{Chans}{ $uchan }{Nicks} } ) { delete $self->{STATE}{Nicks}{ $member }{CHANS}{ $uchan }; if ( keys %{ $self->{STATE}{Nicks}{ $member }{CHANS} } <= 0 ) { delete $self->{STATE}{Nicks}{ $member }; } } delete $self->{STATE}{Chans}{ $uchan }; } else { delete $self->{STATE}{Nicks}{ $nick }{CHANS}{ $uchan }; delete $self->{STATE}{Chans}{ $uchan }{Nicks}{ $nick }; if ( !keys %{ $self->{STATE}{Nicks}{ $nick }{CHANS} } ) { delete $self->{STATE}{Nicks}{ $nick }; } } return PCI_EAT_NONE; } sub S_quit { my ($self, undef) = splice @_, 0, 2; my $map = $self->isupport('CASEMAPPING'); my $nick = (split /!/, ${ $_[0] })[0]; my $msg = ${ $_[1] }; my $unick = uc_irc($nick, $map); my $netsplit = 0; push @{ $_[-1] }, [ $self->nick_channels( $nick ) ]; # Check if it is a netsplit $netsplit = 1 if _is_netsplit( $msg ); if ($unick ne uc_irc($self->nick_name(), $map)) { for my $uchan ( keys %{ $self->{STATE}{Nicks}{ $unick }{CHANS} } ) { delete $self->{STATE}{Chans}{ $uchan }{Nicks}{ $unick }; # No don't stash the channel state. #$self->{NETSPLIT}{Chans}{ $uchan }{NICKS}{ $unick } = $chanstate # if $netsplit; } my $nickstate = delete $self->{STATE}{Nicks}{ $unick }; if ( $netsplit ) { delete $nickstate->{CHANS}; $self->{NETSPLIT}{Users}{ "$unick!" . join '@', @{$nickstate}{qw(User Host)} } = { meta => $nickstate, stamp => time }; } } return PCI_EAT_NONE; } sub _is_netsplit { my $msg = shift || return; return 1 if $msg =~ /^\s*\S+\.[a-z]{2,} \S+\.[a-z]{2,}$/i; return 0; } sub S_kick { my ($self, undef) = splice @_, 0, 2; my $chan = ${ $_[1] }; my $nick = ${ $_[2] }; my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); my $uchan = uc_irc($chan, $map); push @{ $_[-1] }, $self->nick_long_form( $nick ); if ( $unick eq uc_irc($self->nick_name(), $map)) { delete $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan }; delete $self->{STATE}{Chans}{ $uchan }{Nicks}{ $unick }; for my $member ( keys %{ $self->{STATE}{Chans}{ $uchan }{Nicks} } ) { delete $self->{STATE}{Nicks}{ $member }{CHANS}{ $uchan }; if ( keys %{ $self->{STATE}{Nicks}{ $member }{CHANS} } <= 0 ) { delete $self->{STATE}{Nicks}{ $member }; } } delete $self->{STATE}{Chans}{ $uchan }; } else { delete $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan }; delete $self->{STATE}{Chans}{ $uchan }{Nicks}{ $unick }; if ( keys %{ $self->{STATE}{Nicks}{ $unick }{CHANS} } <= 0 ) { delete $self->{STATE}{Nicks}{ $unick }; } } return PCI_EAT_NONE; } sub S_nick { my $self = shift; $self->SUPER::S_nick(@_); shift @_; my $nick = (split /!/, ${ $_[0] })[0]; my $new = ${ $_[1] }; my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); my $unew = uc_irc($new, $map); push @{ $_[-1] }, [ $self->nick_channels( $nick ) ]; if ($unick eq $unew) { # Case Change $self->{STATE}{Nicks}{ $unick }{Nick} = $new; } else { my $user = delete $self->{STATE}{Nicks}{ $unick }; $user->{Nick} = $new; for my $channel ( keys %{ $user->{CHANS} } ) { $self->{STATE}{Chans}{ $channel }{Nicks}{ $unew } = $user->{CHANS}{ $channel }; delete $self->{STATE}{Chans}{ $channel }{Nicks}{ $unick }; } $self->{STATE}{Nicks}{ $unew } = $user; } return PCI_EAT_NONE; } sub S_chan_mode { my ($self, undef) = splice @_, 0, 2; pop @_; my $who = ${ $_[0] }; my $chan = ${ $_[1] }; my $mode = ${ $_[2] }; my $arg = defined $_[3] ? ${ $_[3] } : ''; my $map = $self->isupport('CASEMAPPING'); my $me = uc_irc($self->nick_name(), $map); return PCI_EAT_NONE if $mode !~ /\+[qoah]/ || $me ne uc_irc($arg, $map); my $excepts = $self->isupport('EXCEPTS'); my $invex = $self->isupport('INVEX'); $self->yield(mode => $chan, $excepts ) if $excepts; $self->yield(mode => $chan, $invex ) if $invex; return PCI_EAT_NONE; } # RPL_UMODEIS sub S_221 { my ($self, undef) = splice @_, 0, 2; my $mode = ${ $_[1] }; $mode =~ s/^\+//; $self->{STATE}->{usermode} = $mode; return PCI_EAT_NONE; } # RPL_CHANNEL_URL sub S_328 { my ($self, undef) = splice @_, 0, 2; my ($chan, $url) = @{ ${ $_[2] } }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return PCI_EAT_NONE if !$self->_channel_exists($chan); $self->{STATE}{Chans}{ $uchan }{Url} = $url; return PCI_EAT_NONE; } # RPL_UNAWAY sub S_305 { my ($self, undef) = splice @_, 0, 2; $self->{STATE}->{away} = 0; return PCI_EAT_NONE; } # RPL_NOWAWAY sub S_306 { my ($self, undef) = splice @_, 0, 2; $self->{STATE}->{away} = 1; return PCI_EAT_NONE; } # this code needs refactoring ## no critic (Subroutines::ProhibitExcessComplexity ControlStructures::ProhibitCascadingIfElse) sub S_mode { my ($self, undef) = splice @_, 0, 2; my $map = $self->isupport('CASEMAPPING'); my $who = ${ $_[0] }; my $chan = ${ $_[1] }; my $uchan = uc_irc($chan, $map); pop @_; my @modes = map { ${ $_ } } @_[2 .. $#_]; # CHANMODES is [$list_mode, $always_arg, $arg_when_set, $no_arg] # A $list_mode always has an argument my $prefix = $self->isupport('PREFIX') || { o => '@', v => '+' }; my $statmodes = join '', keys %{ $prefix }; my $chanmodes = $self->isupport('CHANMODES') || [ qw(beI k l imnpstaqr) ]; my $alwaysarg = join '', $statmodes, @{ $chanmodes }[0 .. 1]; # Do nothing if it is UMODE if ($uchan ne uc_irc($self->nick_name(), $map)) { my $parsed_mode = parse_mode_line( $prefix, $chanmodes, @modes ); for my $mode (@{ $parsed_mode->{modes} }) { my $orig_arg; if (length $chanmodes->[2] && length $alwaysarg && $mode =~ /^(.[$alwaysarg]|\+[$chanmodes->[2]])/) { $orig_arg = shift @{ $parsed_mode->{args} }; } my $flag; my $arg = $orig_arg; if (length $statmodes && (($flag) = $mode =~ /\+([$statmodes])/)) { $arg = uc_irc($arg, $map); if (!$self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan } || $self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan } !~ /$flag/) { $self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan } .= $flag; $self->{STATE}{Chans}{ $uchan }{Nicks}{ $arg } = $self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan }; } } elsif (length $statmodes && (($flag) = $mode =~ /-([$statmodes])/)) { $arg = uc_irc($arg, $map); if ($self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan } =~ /$flag/) { $self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan } =~ s/$flag//; $self->{STATE}{Chans}{ $uchan }{Nicks}{ $arg } = $self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan }; } } elsif (length $chanmodes->[0] && (($flag) = $mode =~ /\+([$chanmodes->[0]])/)) { $self->{STATE}{Chans}{ $uchan }{Lists}{ $flag }{ $arg } = { SetBy => $who, SetAt => time(), }; } elsif (length $chanmodes->[0] && (($flag) = $mode =~ /-([$chanmodes->[0]])/)) { delete $self->{STATE}{Chans}{ $uchan }{Lists}{ $flag }{ $arg }; } # All unhandled modes with arguments elsif (length $chanmodes->[3] && (($flag) = $mode =~ /\+([^$chanmodes->[3]])/)) { $self->{STATE}{Chans}{ $uchan }{Mode} .= $flag if $self->{STATE}{Chans}{ $uchan }{Mode} !~ /$flag/; $self->{STATE}{Chans}{ $uchan }{ModeArgs}{ $flag } = $arg; } elsif (length $chanmodes->[3] && (($flag) = $mode =~ /-([^$chanmodes->[3]])/)) { $self->{STATE}{Chans}{ $uchan }{Mode} =~ s/$flag//; delete $self->{STATE}{Chans}{ $uchan }{ModeArgs}{ $flag }; } # Anything else doesn't have arguments so just adjust {Mode} as necessary. elsif (($flag) = $mode =~ /^\+(.)/ ) { $self->{STATE}{Chans}{ $uchan }{Mode} .= $flag if $self->{STATE}{Chans}{ $uchan }{Mode} !~ /$flag/; } elsif (($flag) = $mode =~ /^-(.)/ ) { $self->{STATE}{Chans}{ $uchan }{Mode} =~ s/$flag//; } $self->send_event_next(irc_chan_mode => $who, $chan, $mode, (defined $orig_arg ? $orig_arg : ())); } # Lets make the channel mode nice if ( $self->{STATE}{Chans}{ $uchan }{Mode} ) { $self->{STATE}{Chans}{ $uchan }{Mode} = join('', sort {uc $a cmp uc $b} ( split( //, $self->{STATE}{Chans}{ $uchan }{Mode} ) ) ); } } else { my $parsed_mode = parse_mode_line( @modes ); for my $mode (@{ $parsed_mode->{modes} }) { my $flag; if ( ($flag) = $mode =~ /^\+(.)/ ) { $self->{STATE}{usermode} .= $flag if $self->{STATE}{usermode} !~ /$flag/; } elsif ( ($flag) = $mode =~ /^-(.)/ ) { $self->{STATE}{usermode} =~ s/$flag//; } $self->send_event_next(irc_user_mode => $who, $chan, $mode ); } } return PCI_EAT_NONE; } sub S_topic { my ($self, undef) = splice @_, 0, 2; my $who = ${ $_[0] }; my $chan = ${ $_[1] }; my $topic = ${ $_[2] }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); push @{ $_[-1] }, $self->{STATE}{Chans}{$uchan}{Topic}; $self->{STATE}{Chans}{ $uchan }{Topic} = { Value => $topic, SetBy => $who, SetAt => time(), }; return PCI_EAT_NONE; } # RPL_NAMES sub S_353 { my ($self, undef) = splice @_, 0, 2; my @data = @{ ${ $_[2] } }; shift @data if $data[0] =~ /^[@=*]$/; my $chan = shift @data; my @nicks = split /\s+/, shift @data; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $prefix = $self->isupport('PREFIX') || { o => '@', v => '+' }; my $search = join '|', map { quotemeta } values %$prefix; $search = qr/(?:$search)/; for my $nick (@nicks) { my $status; if ( ($status) = $nick =~ /^($search+)/ ) { $nick =~ s/^($search+)//; } my ($user, $host); if ($self->isupport('UHNAMES')) { ($nick, $user, $host) = split /[!@]/, $nick; } my $unick = uc_irc($nick, $map); $status = '' if !defined $status; my $whatever = ''; my $existing = $self->{STATE}{Nicks}{$unick}{CHANS}{$uchan} || ''; for my $mode (keys %$prefix) { if ($status =~ /\Q$prefix->{$mode}/ && $existing !~ /\Q$prefix->{$mode}/) { $whatever .= $mode; } } $existing .= $whatever if !length $existing || $existing !~ /$whatever/; $self->{STATE}{Nicks}{$unick}{CHANS}{$uchan} = $existing; $self->{STATE}{Chans}{$uchan}{Nicks}{$unick} = $existing; $self->{STATE}{Nicks}{$unick}{Nick} = $nick; if ($self->isupport('UHNAMES')) { $self->{STATE}{Nicks}{$unick}{User} = $user; $self->{STATE}{Nicks}{$unick}{Host} = $host; } } return PCI_EAT_NONE; } # RPL_WHOREPLY sub S_352 { my ($self, undef) = splice @_, 0, 2; my ($chan, $user, $host, $server, $nick, $status, $rest) = @{ ${ $_[2] } }; my ($hops, $real) = split /\x20/, $rest, 2; my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); my $uchan = uc_irc($chan, $map); $self->{STATE}{Nicks}{ $unick }{Nick} = $nick; $self->{STATE}{Nicks}{ $unick }{User} = $user; $self->{STATE}{Nicks}{ $unick }{Host} = $host; if ( !exists $self->{whojoiners} || $self->{whojoiners} ) { $self->{STATE}{Nicks}{ $unick }{Hops} = $hops; $self->{STATE}{Nicks}{ $unick }{Real} = $real; $self->{STATE}{Nicks}{ $unick }{Server} = $server; $self->{STATE}{Nicks}{ $unick }{IRCop} = 1 if $status =~ /\*/; } if ( exists $self->{STATE}{Chans}{ $uchan } ) { my $whatever = ''; my $existing = $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan } || ''; my $prefix = $self->isupport('PREFIX') || { o => '@', v => '+' }; for my $mode ( keys %{ $prefix } ) { if ($status =~ /\Q$prefix->{$mode}/ && $existing !~ /\Q$prefix->{$mode}/ ) { $whatever .= $mode; } } $existing .= $whatever if !$existing || $existing !~ /$whatever/; $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan } = $existing; $self->{STATE}{Chans}{ $uchan }{Nicks}{ $unick } = $existing; $self->{STATE}{Chans}{ $uchan }{Name} = $chan; if ($self->{STATE}{Chans}{ $uchan }{AWAY_SYNCH} && $unick ne uc_irc($self->nick_name(), $map)) { if ( $status =~ /G/ && !$self->{STATE}{Nicks}{ $unick }{Away} ) { $self->send_event_next(irc_user_away => $nick, [ $self->nick_channels( $nick ) ] ); } elsif ($status =~ /H/ && $self->{STATE}{Nicks}{ $unick }{Away} ) { $self->send_event_next(irc_user_back => $nick, [ $self->nick_channels( $nick ) ] ); } } if ($self->{awaypoll}) { $self->{STATE}{Nicks}{ $unick }{Away} = $status =~ /G/ ? 1 : 0; } } return PCI_EAT_NONE; } # RPL_ENDOFWHO sub S_315 { my ($self, undef) = splice @_, 0, 2; my $what = ${ $_[2] }->[0]; my $map = $self->isupport('CASEMAPPING'); my $uwhat = uc_irc($what, $map); if ( exists $self->{STATE}{Chans}{ $uwhat } ) { my $chan = $what; my $uchan = $uwhat; if ( $self->_channel_sync($chan, 'WHO') ) { my $rec = delete $self->{CHANNEL_SYNCH}{ $uchan }; $self->send_event_next(irc_chan_sync => $chan, time() - $rec->{_time} ); } elsif ( $self->{STATE}{Chans}{ $uchan }{AWAY_SYNCH} ) { $self->{STATE}{Chans}{ $uchan }{AWAY_SYNCH} = 0; $poe_kernel->delay_add(_away_sync => $self->{awaypoll} => $chan ); $self->send_event_next(irc_away_sync_end => $chan ); } } else { my $nick = $what; my $unick = $uwhat; my $chan = shift @{ $self->{NICK_SYNCH}{ $unick } }; delete $self->{NICK_SYNCH}{ $unick } if !@{ $self->{NICK_SYNCH}{ $unick } }; $self->send_event_next(irc_nick_sync => $nick, $chan ); } return PCI_EAT_NONE; } # RPL_CREATIONTIME sub S_329 { my ($self, undef) = splice @_, 0, 2; my $map = $self->isupport('CASEMAPPING'); my $chan = ${ $_[2] }->[0]; my $time = ${ $_[2] }->[1]; my $uchan = uc_irc($chan, $map); $self->{STATE}->{Chans}{ $uchan }{CreationTime} = $time; return PCI_EAT_NONE; } # RPL_BANLIST sub S_367 { my ($self, undef) = splice @_, 0, 2; my @args = @{ ${ $_[2] } }; my $chan = shift @args; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my ($mask, $who, $when) = @args; $self->{STATE}{Chans}{ $uchan }{Lists}{b}{ $mask } = { SetBy => $who, SetAt => $when, }; return PCI_EAT_NONE; } # RPL_ENDOFBANLIST sub S_368 { my ($self, undef) = splice @_, 0, 2; my @args = @{ ${ $_[2] } }; my $chan = shift @args; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); if ($self->_channel_sync($chan, 'BAN')) { my $rec = delete $self->{CHANNEL_SYNCH}{ $uchan }; $self->send_event_next(irc_chan_sync => $chan, time() - $rec->{_time} ); } return PCI_EAT_NONE; } # RPL_INVITELIST sub S_346 { my ($self, undef) = splice @_, 0, 2; my ($chan, $mask, $who, $when) = @{ ${ $_[2] } }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $invex = $self->isupport('INVEX'); $self->{STATE}{Chans}{ $uchan }{Lists}{ $invex }{ $mask } = { SetBy => $who, SetAt => $when }; return PCI_EAT_NONE; } # RPL_ENDOFINVITELIST sub S_347 { my ($self, undef) = splice @_, 0, 2; my ($chan) = @{ ${ $_[2] } }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); $self->send_event_next(irc_chan_sync_invex => $chan); return PCI_EAT_NONE; } # RPL_EXCEPTLIST sub S_348 { my ($self, undef) = splice @_, 0, 2; my ($chan, $mask, $who, $when) = @{ ${ $_[2] } }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $excepts = $self->isupport('EXCEPTS'); $self->{STATE}{Chans}{ $uchan }{Lists}{ $excepts }{ $mask } = { SetBy => $who, SetAt => $when, }; return PCI_EAT_NONE; } # RPL_ENDOFEXCEPTLIST sub S_349 { my ($self, undef) = splice @_, 0, 2; my ($chan) = @{ ${ $_[2] } }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); $self->send_event_next(irc_chan_sync_excepts => $chan); return PCI_EAT_NONE; } # RPL_CHANNELMODEIS sub S_324 { my ($self, undef) = splice @_, 0, 2; my @args = @{ ${ $_[2] } }; my $chan = shift @args; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $modes = $self->isupport('CHANMODES') || [ qw(beI k l imnpstaqr) ]; my $prefix = $self->isupport('PREFIX') || { o => '@', v => '+' }; my $parsed_mode = parse_mode_line($prefix, $modes, @args); for my $mode (@{ $parsed_mode->{modes} }) { $mode =~ s/\+//; my $arg = ''; if ($mode =~ /[^$modes->[3]]/) { # doesn't match a mode with no args $arg = shift @{ $parsed_mode->{args} }; } if ( $self->{STATE}{Chans}{ $uchan }{Mode} ) { $self->{STATE}{Chans}{ $uchan }{Mode} .= $mode if $self->{STATE}{Chans}{ $uchan }{Mode} !~ /$mode/; } else { $self->{STATE}{Chans}{ $uchan }{Mode} = $mode; } $self->{STATE}{Chans}{ $uchan }{ModeArgs}{ $mode } = $arg if defined ( $arg ); } if ( $self->{STATE}{Chans}{ $uchan }{Mode} ) { $self->{STATE}{Chans}{ $uchan }{Mode} = join('', sort {uc $a cmp uc $b} split //, $self->{STATE}{Chans}{ $uchan }{Mode} ); } if ( $self->_channel_sync($chan, 'MODE') ) { my $rec = delete $self->{CHANNEL_SYNCH}{ $uchan }; $self->send_event_next(irc_chan_sync => $chan, time() - $rec->{_time} ); } return PCI_EAT_NONE; } # RPL_TOPIC sub S_332 { my ($self, undef) = splice @_, 0, 2; my $chan = ${ $_[2] }->[0]; my $topic = ${ $_[2] }->[1]; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); $self->{STATE}{Chans}{ $uchan }{Topic}{Value} = $topic; return PCI_EAT_NONE; } # RPL_TOPICWHOTIME sub S_333 { my ($self, undef) = splice @_, 0, 2; my ($chan, $who, $when) = @{ ${ $_[2] } }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); $self->{STATE}{Chans}{ $uchan }{Topic}{SetBy} = $who; $self->{STATE}{Chans}{ $uchan }{Topic}{SetAt} = $when; return PCI_EAT_NONE; } # Methods for STATE query # Internal methods begin with '_' # sub umode { my ($self) = @_; return $self->{STATE}{usermode}; } sub is_user_mode_set { my ($self, $mode) = @_; if (!defined $mode) { warn 'User mode is undefined'; return; } $mode = (split //, $mode)[0] || return; $mode =~ s/[^A-Za-z]//g; return if !$mode; return 1 if $self->{STATE}{usermode} =~ /$mode/; return; } sub _away_sync { my ($self, $chan) = @_[OBJECT, ARG0]; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); $self->{STATE}{Chans}{ $uchan }{AWAY_SYNCH} = 1; $self->yield(who => $chan); $self->send_event(irc_away_sync_start => $chan); return; } sub _channel_sync { my ($self, $chan, $sync) = @_; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan) || !defined $self->{CHANNEL_SYNCH}{ $uchan }; $self->{CHANNEL_SYNCH}{ $uchan }{ $sync } = 1 if $sync; for my $item ( qw(BAN MODE WHO) ) { return if !$self->{CHANNEL_SYNCH}{ $uchan }{ $item }; } return 1; } sub _nick_exists { my ($self, $nick) = @_; my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); return 1 if exists $self->{STATE}{Nicks}{ $unick }; return; } sub _channel_exists { my ($self, $chan) = @_; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return 1 if exists $self->{STATE}{Chans}{ $uchan }; return; } sub _nick_has_channel_mode { my ($self, $chan, $nick, $flag) = @_; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $unick = uc_irc($nick, $map); $flag = (split //, $flag)[0]; return if !$self->is_channel_member($uchan, $unick); return 1 if $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan } =~ /$flag/; return; } # Returns all the channels that the bot is on with an indication of # whether it has operator, halfop or voice. sub channels { my ($self) = @_; my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($self->nick_name(), $map); my %result; if (defined $unick && $self->_nick_exists($unick)) { for my $uchan ( keys %{ $self->{STATE}{Nicks}{ $unick }{CHANS} } ) { $result{ $self->{STATE}{Chans}{ $uchan }{Name} } = $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan }; } } return \%result; } sub nicks { my ($self) = @_; return map { $self->{STATE}{Nicks}{$_}{Nick} } keys %{ $self->{STATE}{Nicks} }; } sub nick_info { my ($self, $nick) = @_; if (!defined $nick) { warn 'Nickname is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); return if !$self->_nick_exists($nick); my $user = $self->{STATE}{Nicks}{ $unick }; my %result = %{ $user }; # maybe we haven't synced this user's info yet if (defined $result{User} && defined $result{Host}) { $result{Userhost} = "$result{User}\@$result{Host}"; } delete $result{'CHANS'}; return \%result; } sub nick_long_form { my ($self, $nick) = @_; if (!defined $nick) { warn 'Nickname is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); return if !$self->_nick_exists($nick); my $user = $self->{STATE}{Nicks}{ $unick }; return unless exists $user->{User} && exists $user->{Host}; return "$user->{Nick}!$user->{User}\@$user->{Host}"; } sub nick_channels { my ($self, $nick) = @_; if (!defined $nick) { warn 'Nickname is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); return if !$self->_nick_exists($nick); return map { $self->{STATE}{Chans}{$_}{Name} } keys %{ $self->{STATE}{Nicks}{ $unick }{CHANS} }; } sub channel_list { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan); return map { $self->{STATE}{Nicks}{$_}{Nick} } keys %{ $self->{STATE}{Chans}{ $uchan }{Nicks} }; } sub is_away { my ($self, $nick) = @_; if (!defined $nick) { warn 'Nickname is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); if ($unick eq uc_irc($self->nick_name())) { # more accurate return 1 if $self->{STATE}{away}; return; } return if !$self->_nick_exists($nick); return 1 if $self->{STATE}{Nicks}{ $unick }{Away}; return; } sub is_operator { my ($self, $nick) = @_; if (!defined $nick) { warn 'Nickname is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); return if !$self->_nick_exists($nick); return 1 if $self->{STATE}{Nicks}{ $unick }{IRCop}; return; } sub is_channel_mode_set { my ($self, $chan, $mode) = @_; if (!defined $chan || !defined $mode) { warn 'Channel or mode is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); $mode = (split //, $mode)[0]; return if !$self->_channel_exists($chan) || !$mode; $mode =~ s/[^A-Za-z]//g; if (defined $self->{STATE}{Chans}{ $uchan }{Mode} && $self->{STATE}{Chans}{ $uchan }{Mode} =~ /$mode/) { return 1; } return; } sub is_channel_synced { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } return $self->_channel_sync($chan); } sub channel_creation_time { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan); return if !exists $self->{STATE}{Chans}{ $uchan }{CreationTime}; return $self->{STATE}{Chans}{ $uchan }{CreationTime}; } sub channel_limit { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan); if ( $self->is_channel_mode_set($chan, 'l') && defined $self->{STATE}{Chans}{ $uchan }{ModeArgs}{l} ) { return $self->{STATE}{Chans}{ $uchan }{ModeArgs}{l}; } return; } sub channel_key { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan); if ( $self->is_channel_mode_set($chan, 'k') && defined $self->{STATE}{Chans}{ $uchan }{ModeArgs}{k} ) { return $self->{STATE}{Chans}{ $uchan }{ModeArgs}{k}; } return; } sub channel_modes { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan); my %modes; if ( defined $self->{STATE}{Chans}{ $uchan }{Mode} ) { %modes = map { ($_ => '') } split(//, $self->{STATE}{Chans}{ $uchan }{Mode}); } if ( defined $self->{STATE}{Chans}{ $uchan }->{ModeArgs} ) { my %args = %{ $self->{STATE}{Chans}{ $uchan }{ModeArgs} }; @modes{keys %args} = values %args; } return \%modes; } sub is_channel_member { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nickname is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $unick = uc_irc($nick, $map); return if !$self->_channel_exists($chan) || !$self->_nick_exists($nick); return 1 if defined $self->{STATE}{Chans}{ $uchan }{Nicks}{ $unick }; return; } sub is_channel_operator { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nickname is undefined'; return; } return 1 if $self->_nick_has_channel_mode($chan, $nick, 'o'); return; } sub has_channel_voice { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nickname is undefined'; return; } return 1 if $self->_nick_has_channel_mode($chan, $nick, 'v'); return; } sub is_channel_halfop { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nickname is undefined'; return; } return 1 if $self->_nick_has_channel_mode($chan, $nick, 'h'); return; } sub is_channel_owner { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nickname is undefined'; return; } return 1 if $self->_nick_has_channel_mode($chan, $nick, 'q'); return; } sub is_channel_admin { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nickname is undefined'; return; } return 1 if $self->_nick_has_channel_mode($chan, $nick, 'a'); return; } sub ban_mask { my ($self, $chan, $mask) = @_; if (!defined $chan || !defined $mask) { warn 'Channel or mask is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); $mask = normalize_mask($mask); my @result; return if !$self->_channel_exists($chan); # Convert the mask from IRC to regex. $mask = uc_irc($mask, $map); $mask = quotemeta $mask; $mask =~ s/\\\*/[\x01-\xFF]{0,}/g; $mask =~ s/\\\?/[\x01-\xFF]{1,1}/g; for my $nick ( $self->channel_list($chan) ) { push @result, $nick if uc_irc($self->nick_long_form($nick)) =~ /^$mask$/; } return @result; } sub channel_ban_list { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my %result; return if !$self->_channel_exists($chan); if ( defined $self->{STATE}{Chans}{ $uchan }{Lists}{b} ) { %result = %{ $self->{STATE}{Chans}{ $uchan }{Lists}{b} }; } return \%result; } sub channel_except_list { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $excepts = $self->isupport('EXCEPTS'); my %result; return if !$self->_channel_exists($chan); if ( defined $self->{STATE}{Chans}{ $uchan }{Lists}{ $excepts } ) { %result = %{ $self->{STATE}{Chans}{ $uchan }{Lists}{ $excepts } }; } return \%result; } sub channel_invex_list { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $invex = $self->isupport('INVEX'); my %result; return if !$self->_channel_exists($chan); if ( defined $self->{STATE}{Chans}{ $uchan }{Lists}{ $invex } ) { %result = %{ $self->{STATE}{Chans}{ $uchan }{Lists}{ $invex } }; } return \%result; } sub channel_topic { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my %result; return if !$self->_channel_exists($chan); if ( defined $self->{STATE}{Chans}{ $uchan }{Topic} ) { %result = %{ $self->{STATE}{Chans}{ $uchan }{Topic} }; } return \%result; } sub channel_url { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan); return $self->{STATE}{Chans}{ $uchan }{Url}; } sub nick_channel_modes { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nick is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $unick = uc_irc($nick, $map); return if !$self->is_channel_member($chan, $nick); return $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan }; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::State - A fully event-driven IRC client module with nickname and channel tracking =head1 SYNOPSIS # A simple Rot13 'encryption' bot use strict; use warnings; use POE qw(Component::IRC::State); my $nickname = 'Flibble' . $$; my $ircname = 'Flibble the Sailor Bot'; my $ircserver = 'irc.blahblahblah.irc'; my $port = 6667; my @channels = ( '#Blah', '#Foo', '#Bar' ); # We create a new PoCo-IRC object and component. my $irc = POE::Component::IRC::State->spawn( nick => $nickname, server => $ircserver, port => $port, ircname => $ircname, ) or die "Oh noooo! $!"; POE::Session->create( package_states => [ main => [ qw(_default _start irc_001 irc_public) ], ], heap => { irc => $irc }, ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; # We get the session ID of the component from the object # and register and connect to the specified server. my $irc_session = $heap->{irc}->session_id(); $kernel->post( $irc_session => register => 'all' ); $kernel->post( $irc_session => connect => { } ); return; } sub irc_001 { my ($kernel, $sender) = @_[KERNEL, SENDER]; # Get the component's object at any time by accessing the heap of # the SENDER my $poco_object = $sender->get_heap(); print "Connected to ", $poco_object->server_name(), "\n"; # In any irc_* events SENDER will be the PoCo-IRC session $kernel->post( $sender => join => $_ ) for @channels; return; } sub irc_public { my ($kernel ,$sender, $who, $where, $what) = @_[KERNEL, SENDER, ARG0 .. ARG2]; my $nick = ( split /!/, $who )[0]; my $channel = $where->[0]; my $poco_object = $sender->get_heap(); if ( my ($rot13) = $what =~ /^rot13 (.+)/ ) { # Only operators can issue a rot13 command to us. return if !$poco_object->is_channel_operator( $channel, $nick ); $rot13 =~ tr[a-zA-Z][n-za-mN-ZA-M]; $kernel->post( $sender => privmsg => $channel => "$nick: $rot13" ); } return; } # We registered for all events, this will produce some debug info. sub _default { my ($event, $args) = @_[ARG0 .. $#_]; my @output = ( "$event: " ); for my $arg ( @$args ) { if (ref $arg eq 'ARRAY') { push( @output, '[' . join(', ', @$arg ) . ']' ); } else { push ( @output, "'$arg'" ); } } print join ' ', @output, "\n"; return 0; } =head1 DESCRIPTION POE::Component::IRC::State is a sub-class of L which tracks IRC state entities such as nicks and channels. See the documentation for L for general usage. This document covers the extra methods that POE::Component::IRC::State provides. The component tracks channels and nicks, so that it always has a current snapshot of what channels it is on and who else is on those channels. The returned object provides methods to query the collected state. =head1 CONSTRUCTORS POE::Component::IRC::State's constructors, and its C event, all take the same arguments as L does, as well as two additional ones: B<'AwayPoll'>, the interval (in seconds) in which to poll (i.e. C) the away status of channel members. Defaults to 0 (disabled). If enabled, you will receive C / L|/irc_user_away> / L|/irc_user_back> events, and will be able to use the L|/is_away> method for users other than yourself. This can cause a lot of increase in traffic, especially if you are on big channels, so if you do use this, you probably don't want to set it too low. For reference, X-Chat uses 300 seconds (5 minutes). B<'WhoJoiners'>, a boolean indicating whether the component should send a C for every person which joins a channel. Defaults to on (the C is sent). If you turn this off, L|/is_operator> will not work and L|/nick_info> will only return the keys B<'Nick'>, B<'User'>, B<'Host'> and B<'Userhost'>. =head1 METHODS All of the L methods are supported, plus the following: =head2 C Expects a channel and a ban mask, as passed to MODE +b-b. Returns a list of nicks on that channel that match the specified ban mask or an empty list if the channel doesn't exist in the state or there are no matches. =head2 C Expects a channel as a parameter. Returns a hashref containing the banlist if the channel is in the state, a false value if not. The hashref keys are the entries on the list, each with the keys B<'SetBy'> and B<'SetAt'>. These keys will hold the nick!hostmask of the user who set the entry (or just the nick if it's all the ircd gives us), and the time at which it was set respectively. =head2 C Expects a channel as parameter. Returns channel creation time or a false value. =head2 C Expects a channel as a parameter. Returns a hashref containing the ban exception list if the channel is in the state, a false value if not. The hashref keys are the entries on the list, each with the keys B<'SetBy'> and B<'SetAt'>. These keys will hold the nick!hostmask of the user who set the entry (or just the nick if it's all the ircd gives us), and the time at which it was set respectively. =head2 C Expects a channel as a parameter. Returns a hashref containing the invite exception list if the channel is in the state, a false value if not. The hashref keys are the entries on the list, each with the keys B<'SetBy'> and B<'SetAt'>. These keys will hold the nick!hostmask of the user who set the entry (or just the nick if it's all the ircd gives us), and the time at which it was set respectively. =head2 C Expects a channel as parameter. Returns the channel key or a false value. =head2 C Expects a channel as parameter. Returns the channel limit or a false value. =head2 C Expects a channel as parameter. Returns a list of all nicks on the specified channel. If the component happens to not be on that channel an empty list will be returned. =head2 C Expects a channel as parameter. Returns a hash ref keyed on channel mode, with the mode argument (if any) as the value. Returns a false value instead if the channel is not in the state. =head2 C Takes no parameters. Returns a hashref, keyed on channel name and whether the bot is operator, halfop or has voice on that channel. for my $channel ( keys %{ $irc->channels() } ) { $irc->yield( 'privmsg' => $channel => 'm00!' ); } =head2 C Expects a channel as a parameter. Returns a hashref containing topic information if the channel is in the state, a false value if not. The hashref contains the following keys: B<'Value'>, B<'SetBy'>, B<'SetAt'>. These keys will hold the topic itself, the nick!hostmask of the user who set it (or just the nick if it's all the ircd gives us), and the time at which it was set respectively. If the component happens to not be on the channel, nothing will be returned. =head2 C Expects a channel as a parameter. Returns the channel's URL. If the channel has no URL or the component is not on the channel, nothing will be returned. =head2 C Expects a channel and a nickname as parameters. Returns a true value if the nick has voice on the specified channel. Returns false if the nick does not have voice on the channel or if the nick/channel does not exist in the state. =head2 C Expects a nick as parameter. Returns a true value if the specified nick is away. Returns a false value if the nick is not away or not in the state. This will only work for your IRC user unless you specified a value for B<'AwayPoll'> in L|POE::Component::IRC/spawn>. =head2 C Expects a channel and a nickname as parameters. Returns a true value if the nick is an admin on the specified channel. Returns false if the nick is not an admin on the channel or if the nick/channel does not exist in the state. =head2 C Expects a channel and a nickname as parameters. Returns a true value if the nick is a half-operator on the specified channel. Returns false if the nick is not a half-operator on the channel or if the nick/channel does not exist in the state. =head2 C Expects a channel and a nickname as parameters. Returns a true value if the nick is on the specified channel. Returns false if the nick is not on the channel or if the nick/channel does not exist in the state. =head2 C Expects a channel and a single mode flag C<[A-Za-z]>. Returns a true value if that mode is set on the channel. =head2 C Expects a channel and a nickname as parameters. Returns a true value if the nick is an operator on the specified channel. Returns false if the nick is not an operator on the channel or if the nick/channel does not exist in the state. =head2 C Expects a channel and a nickname as parameters. Returns a true value if the nick is an owner on the specified channel. Returns false if the nick is not an owner on the channel or if the nick/channel does not exist in the state. =head2 C Expects a channel as a parameter. Returns true if the channel has been synced. Returns false if it has not been synced or if the channel is not in the state. =head2 C Expects a nick as parameter. Returns a true value if the specified nick is an IRC operator. Returns a false value if the nick is not an IRC operator or is not in the state. =head2 C Expects single user mode flag C<[A-Za-z]>. Returns a true value if that user mode is set. =head2 C Expects a channel and a nickname as parameters. Returns the modes of the specified nick on the specified channel (ie. qaohv). If the nick is not on the channel in the state, a false value will be returned. =head2 C Expects a nickname. Returns a list of the channels that that nickname and the component are on. An empty list will be returned if the nickname does not exist in the state. =head2 C Expects a nickname. Returns a hashref containing similar information to that returned by WHOIS. Returns a false value if the nickname doesn't exist in the state. The hashref contains the following keys: B<'Nick'>, B<'User'>, B<'Host'>, B<'Userhost'>, B<'Hops'>, B<'Real'>, B<'Server'> and, if applicable, B<'IRCop'>. =head2 C Expects a nickname. Returns the long form of that nickname, ie. C or a false value if the nick is not in the state. =head2 C Takes no parameters. Returns a list of all the nicks, including itself, that it knows about. If the component happens to be on no channels then an empty list is returned. =head2 C Takes no parameters. Returns the current user mode set for the bot. =head1 OUTPUT EVENTS =head2 Augmented events New parameters are added to the following L events. =head3 C See also L|POE::Component::IRC/irc_quit> in L. Additional parameter C contains an arrayref of channel names that are common to the quitting client and the component. =head3 C See also L|POE::Component::IRC/irc_nick> in L. Additional parameter C contains an arrayref of channel names that are common to the nick hanging client and the component. =head3 C See also L|POE::Component::IRC/irc_kick> in L. Additional parameter C contains the full nick!user@host of the kicked individual. =head3 C See also L|POE::Component::IRC/irc_kick> in L. Additional parameter C contains the old topic hashref, like the one returned by L|/channel_topic>. =head3 C =head3 C =head3 C These three all have two additional parameters. C is a hash of information about your IRC user (see L|/nick_info>), while C is a hash of the channels you were on (see L|/channels>). =head2 New events As well as all the usual L C events, there are the following events you can register for: =head3 C Sent whenever the component starts to synchronise the away statuses of channel members. C is the channel name. You will only receive this event if you specified a value for B<'AwayPoll'> in L|POE::Component::IRC/spawn>. =head3 C Sent whenever the component has completed synchronising the away statuses of channel members. C is the channel name. You will only receive this event if you specified a value for B<'AwayPoll'> in L|POE::Component::IRC/spawn>. =head3 C This is almost identical to L|POE::Component::IRC/irc_mode>, except that it's sent once for each individual mode with it's respective argument if it has one (ie. the banmask if it's +b or -b). However, this event is only sent for channel modes. =head3 C Sent whenever the component has completed synchronising a channel that it has joined. C is the channel name and C is the time in seconds that the channel took to synchronise. =head3 C Sent whenever the component has completed synchronising a channel's INVEX (invite list). Usually triggered by the component being opped on a channel. C is the channel name. =head3 C Sent whenever the component has completed synchronising a channel's EXCEPTS (ban exemption list). Usually triggered by the component being opped on a channel. C is the channel. =head3 C Sent whenever the component has completed synchronising a user who has joined a channel the component is on. C is the user's nickname and C the channel they have joined. =head3 C Sent when an IRC user sets his/her status to away. C is the nickname, C is an arrayref of channel names that are common to the nickname and the component. You will only receive this event if you specified a value for B<'AwayPoll'> in L|POE::Component::IRC/spawn>. B This above is only for users I. To know when you change your own away status, register for the C and C events. =head3 C Sent when an IRC user unsets his/her away status. C is the nickname, C is an arrayref of channel names that are common to the nickname and the component. You will only receive this event if you specified a value for B<'AwayPoll'> in L|POE::Component::IRC/spawn>. B This above is only for users I. To know when you change your own away status, register for the C and C events. =head3 C This is almost identical to L|POE::Component::IRC/irc_mode>, except it is sent for each individual umode that is being set. =head1 CAVEATS The component gathers information by registering for C, C, C, C, C, C and various numeric replies. When the component is asked to join a channel, when it joins it will issue 'WHO #channel', 'MODE #channel', and 'MODE #channel b'. These will solicit between them the numerics, C, C and C, respectively. When someone joins a channel the bot is on, it issues a 'WHO nick'. You may want to ignore these. Currently, whenever the component sees a topic or channel list change, it will use C