circle-be-0.173320000755001750001750 013207602007 12314 5ustar00leoleo000000000000circle-be-0.173320/Build.PL000444001750001750 216413207602007 13750 0ustar00leoleo000000000000use strict; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'Circle', dist_name => 'circle-be', configure_requires => { 'Module::Build' => '0.4004', # test_requires }, requires => { 'Attribute::Storage' => '0.09', 'Class::Method::Modifiers' => 0, 'Data::Dump' => 0, 'File::Basename' => 0, 'File::Path' => 0, 'File::ShareDir' => 0, 'IO::Async::Listener' => '0.64', 'IO::Async::Loop' => '0.37', 'Module::Pluggable' => '4.1', # force_search_all_paths 'Net::Async::IRC' => '0.10', 'Net::Async::Tangence::Server' => '0.13', 'String::Tagged' => '0.11', 'Struct::Dumb' => 0, 'Tangence::Message' => '0.11', 'Tangence::Object' => '0.18', 'Tangence::Registry' => '0.20', # late-loading of classes 'YAML' => 0, 'perl' => '5.010', }, test_requires => { 'Test::Identity' => 0, 'Test::More' => 0, }, share_dir => { module => { "Circle" => "share" }, }, license => 'perl', create_license => 1, create_readme => 1, ); $build->create_build_script; circle-be-0.173320/Changes000444001750001750 1261313207602007 13767 0ustar00leoleo000000000000Revision history for Circle 0.173320 2017-11-29 18:55:36 [CHANGES] * Better support for formatted strings via String::Tagged::Formatting spec * Better support for other features used by Circle::Net::Matrix * Added `/invite` IRC channel command * Commandline-overridable config file path * Added logfile formatter script * Remove unused-and-buggy channel join state tracking code [BUGFIXES] * Fixes for IO::Async 0.64 and Net::Async::Tangence API changes (RT101151) 0.170740 2017/03/16 14:54:14 [CHANGES] * Added `/channels del` * Added `-all` option to `/show` command * Extracted `Circle::Net` common base class * Accept `--` to command parser to indicate end of named options, allowing positional argument text to begin with `-` [BUGFIXES] * Bundle multiple JOIN messages together to avoid flooding IRC servers on connect * Refuse to start a second time if the UNIX socket appears to be alive * More graceful handling of IRC streaming errors 0.142470 2014/09/05 17:46:57 [CHANGES] * Added a logging system * Rebuilt the Circle::Configurable subsystem, allows inheritable settings * Support late-loading of Tangence::Class definitions of Circle::Net, subclasses thus paving the way for out-of-tree network types [BUGFIXES] * Make unit tests work again on latest NaTangence 0.140500 2014/02/20 15:02:21 [CHANGES] * Make IRC /disconnect message optional * Added /whois, /requery * Added overlong PRIVMSG splitting over multiple messages [BUGFIXES] * Don't try to look up IO::Socket::SSL::SSL_VERIFY_NONE when IO::Socket::SSL may not be loaded * IRC network connect with alternate ident now obeys it * NaIRC 0.09 is now a regular Stream, not a Protocol 0.132860 2013/10/14 15:00:44 [CHANGES] * Connect IRC using Futures * Allow networks to be deleted * Support SSL * Added /reconnect command to IRC 0.132150 CHANGES: * Implement a /disconnect IRC command * Added /dumpevents and associated event log formatter * Allow /topic alone to redisplay the full text of a channel topic * Bugfix to 'on_enter' handling of channel topic Entry widget * Configurable use of mIRC colouring hints 0.131390 CHANGES: * Allow circlerc location to be overridden by an env.var. * An attempt at IRC reconnect logic * Allow widgets to declare a set of style classes * Longer ping times * Load channel keys on startup * Bugfix: IO::Async::OS has ->socketpair now * Use new named server numerics from NaIRC 0.07 * Handle a few more channel information numerics 0.130560 CHANGES: * Bugfix to user ident string setting * Bugfix to server name display on server-forced MODE changes * Updates for Tangence 0.18 0.130330 CHANGES: * Support channel join keys * Display user ident string above the main event scroller in user query windows * Bugfix "channel()" rules engine condition * Bugfixes to IRC network disconnect handling 0.123420 CHANGES: * Implement tab-completion groups * Provide tab-complete for IRC channel names, and occupants in each channel * Added /tab goto command to raise a window on all the FEs + TODO: Consider only for one FE 0.123270 CHANGES: * Maintain a network status display for IRC networks in the tag name widget * Handle ping timeout * Avoid harmless "lvalue in substr()" warning from IO::Async 0.122910 CHANGES: * Added /rules condition of isaction (for IRC) * Added /rules actions of rewrite (globally) and chaction (for IRC) * Added /rules chain for output on IRC and Raw networks 0.122820 CHANGES: * Switched to date-based version numbering scheme http://rjbs.manxome.org/rubric/entry/1749 * Added --help option * Added some unit testing * Ensure that CommandInvocation objects don't hold the underlying Tangence connection * Cleaner handling of configured-vs-running nick * Require --stdio flag to listen on STDIO * Display IRC network name on network and channel tab status bars * Parse IRC formatting for actual-italics and RV 0.04 CHANGES: * Initial attempt at real unit tests * Send application-level warnings to root object as 'warning' events * Install circle.tan into sharedir * Allow setting a local host name to bind for IRC connections BUGFIXES: * Add NaIRC to Loop at construct time * Make stdin/stdout connect scheme actually work * Remove kickee on IRC KICK, not kicker 0.03 CHANGES: * Updated for Tangence 0.06 * Persistance of sessions in config 0.02 CHANGES: * Updated for Tangence 0.03 * Added '/kick' command * Persistance of IRC channels in config BUGFIXED: * 'use strict; use warnings;' in all files * Declare dependency on String::Tagged 0.01 First version, released on an unsuspecting world. circle-be-0.173320/LICENSE000444001750001750 4376213207602007 13512 0ustar00leoleo000000000000This software is copyright (c) 2017 by Paul Evans . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2017 by Paul Evans . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2017 by Paul Evans . This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End circle-be-0.173320/MANIFEST000444001750001750 163013207602007 13602 0ustar00leoleo000000000000bin/circle-be bin/circle-parse-eventdump bin/circle-parse-yamllog Build.PL Changes circle-be lib/Circle.pm lib/Circle/Collection.pm lib/Circle/Command.pm lib/Circle/Commandable.pm lib/Circle/CommandInvocation.pm lib/Circle/Configurable.pm lib/Circle/GlobalRules.pm lib/Circle/Loggable.pm lib/Circle/Net.pm lib/Circle/Net/IRC.pm lib/Circle/Net/IRC/Channel.pm lib/Circle/Net/IRC/Target.pm lib/Circle/Net/IRC/User.pm lib/Circle/Net/Raw.pm lib/Circle/RootObj.pm lib/Circle/Rule/Chain.pm lib/Circle/Rule/Resultset.pm lib/Circle/Rule/Store.pm lib/Circle/Ruleable.pm lib/Circle/Session/Tabbed.pm lib/Circle/TaggedString.pm lib/Circle/Widget.pm lib/Circle/Widget/Box.pm lib/Circle/Widget/Entry.pm lib/Circle/Widget/Label.pm lib/Circle/Widget/Scroller.pm lib/Circle/WindowItem.pm LICENSE MANIFEST This list of files META.json META.yml README share/circle.tan t/00use.t t/01rootobj.t t/02session.t t/50net-raw.t t/CircleTest.pm circle-be-0.173320/META.json000444001750001750 1153713207602007 14121 0ustar00leoleo000000000000{ "abstract" : "server backend for the C application host", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4224", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "circle-be", "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0.4004" } }, "runtime" : { "requires" : { "Attribute::Storage" : "0.09", "Class::Method::Modifiers" : "0", "Data::Dump" : "0", "File::Basename" : "0", "File::Path" : "0", "File::ShareDir" : "1.00", "IO::Async::Listener" : "0.64", "IO::Async::Loop" : "0.37", "Module::Pluggable" : "4.1", "Net::Async::IRC" : "0.10", "Net::Async::Tangence::Server" : "0.13", "String::Tagged" : "0.11", "Struct::Dumb" : "0", "Tangence::Message" : "0.11", "Tangence::Object" : "0.18", "Tangence::Registry" : "0.20", "YAML" : "0", "perl" : "5.010" } }, "test" : { "requires" : { "Test::Identity" : "0", "Test::More" : "0" } } }, "provides" : { "Circle" : { "file" : "lib/Circle.pm", "version" : "0.173320" }, "Circle::Collection" : { "file" : "lib/Circle/Collection.pm", "version" : "0.173320" }, "Circle::Command" : { "file" : "lib/Circle/Command.pm", "version" : "0.173320" }, "Circle::CommandInvocation" : { "file" : "lib/Circle/CommandInvocation.pm", "version" : "0.173320" }, "Circle::Commandable" : { "file" : "lib/Circle/Commandable.pm", "version" : "0.173320" }, "Circle::Configurable" : { "file" : "lib/Circle/Configurable.pm", "version" : "0.173320" }, "Circle::GlobalRules" : { "file" : "lib/Circle/GlobalRules.pm", "version" : "0.173320" }, "Circle::Loggable" : { "file" : "lib/Circle/Loggable.pm", "version" : "0.173320" }, "Circle::Net" : { "file" : "lib/Circle/Net.pm", "version" : "0.173320" }, "Circle::Net::IRC" : { "file" : "lib/Circle/Net/IRC.pm", "version" : "0.173320" }, "Circle::Net::IRC::Channel" : { "file" : "lib/Circle/Net/IRC/Channel.pm", "version" : "0.173320" }, "Circle::Net::IRC::Target" : { "file" : "lib/Circle/Net/IRC/Target.pm", "version" : "0.173320" }, "Circle::Net::IRC::User" : { "file" : "lib/Circle/Net/IRC/User.pm", "version" : "0.173320" }, "Circle::Net::Raw" : { "file" : "lib/Circle/Net/Raw.pm", "version" : "0.173320" }, "Circle::RootObj" : { "file" : "lib/Circle/RootObj.pm", "version" : "0.173320" }, "Circle::Rule::Chain" : { "file" : "lib/Circle/Rule/Chain.pm", "version" : "0.173320" }, "Circle::Rule::Resultset" : { "file" : "lib/Circle/Rule/Resultset.pm", "version" : "0.173320" }, "Circle::Rule::Store" : { "file" : "lib/Circle/Rule/Store.pm", "version" : "0.173320" }, "Circle::Ruleable" : { "file" : "lib/Circle/Ruleable.pm", "version" : "0.173320" }, "Circle::Session::Tabbed" : { "file" : "lib/Circle/Session/Tabbed.pm", "version" : "0.173320" }, "Circle::TaggedString" : { "file" : "lib/Circle/TaggedString.pm", "version" : "0.173320" }, "Circle::Widget" : { "file" : "lib/Circle/Widget.pm", "version" : "0.173320" }, "Circle::Widget::Box" : { "file" : "lib/Circle/Widget/Box.pm", "version" : "0.173320" }, "Circle::Widget::Entry" : { "file" : "lib/Circle/Widget/Entry.pm", "version" : "0.173320" }, "Circle::Widget::Entry::CompleteGroup" : { "file" : "lib/Circle/Widget/Entry.pm" }, "Circle::Widget::Label" : { "file" : "lib/Circle/Widget/Label.pm", "version" : "0.173320" }, "Circle::Widget::Scroller" : { "file" : "lib/Circle/Widget/Scroller.pm", "version" : "0.173320" }, "Circle::WindowItem" : { "file" : "lib/Circle/WindowItem.pm", "version" : "0.173320" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.173320", "x_serialization_backend" : "JSON::PP version 2.27400_02" } circle-be-0.173320/META.yml000444001750001750 637613207602007 13736 0ustar00leoleo000000000000--- abstract: 'server backend for the C application host' author: - 'Paul Evans ' build_requires: Test::Identity: '0' Test::More: '0' configure_requires: Module::Build: '0.4004' dynamic_config: 1 generated_by: 'Module::Build version 0.4224, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: circle-be provides: Circle: file: lib/Circle.pm version: '0.173320' Circle::Collection: file: lib/Circle/Collection.pm version: '0.173320' Circle::Command: file: lib/Circle/Command.pm version: '0.173320' Circle::CommandInvocation: file: lib/Circle/CommandInvocation.pm version: '0.173320' Circle::Commandable: file: lib/Circle/Commandable.pm version: '0.173320' Circle::Configurable: file: lib/Circle/Configurable.pm version: '0.173320' Circle::GlobalRules: file: lib/Circle/GlobalRules.pm version: '0.173320' Circle::Loggable: file: lib/Circle/Loggable.pm version: '0.173320' Circle::Net: file: lib/Circle/Net.pm version: '0.173320' Circle::Net::IRC: file: lib/Circle/Net/IRC.pm version: '0.173320' Circle::Net::IRC::Channel: file: lib/Circle/Net/IRC/Channel.pm version: '0.173320' Circle::Net::IRC::Target: file: lib/Circle/Net/IRC/Target.pm version: '0.173320' Circle::Net::IRC::User: file: lib/Circle/Net/IRC/User.pm version: '0.173320' Circle::Net::Raw: file: lib/Circle/Net/Raw.pm version: '0.173320' Circle::RootObj: file: lib/Circle/RootObj.pm version: '0.173320' Circle::Rule::Chain: file: lib/Circle/Rule/Chain.pm version: '0.173320' Circle::Rule::Resultset: file: lib/Circle/Rule/Resultset.pm version: '0.173320' Circle::Rule::Store: file: lib/Circle/Rule/Store.pm version: '0.173320' Circle::Ruleable: file: lib/Circle/Ruleable.pm version: '0.173320' Circle::Session::Tabbed: file: lib/Circle/Session/Tabbed.pm version: '0.173320' Circle::TaggedString: file: lib/Circle/TaggedString.pm version: '0.173320' Circle::Widget: file: lib/Circle/Widget.pm version: '0.173320' Circle::Widget::Box: file: lib/Circle/Widget/Box.pm version: '0.173320' Circle::Widget::Entry: file: lib/Circle/Widget/Entry.pm version: '0.173320' Circle::Widget::Entry::CompleteGroup: file: lib/Circle/Widget/Entry.pm Circle::Widget::Label: file: lib/Circle/Widget/Label.pm version: '0.173320' Circle::Widget::Scroller: file: lib/Circle/Widget/Scroller.pm version: '0.173320' Circle::WindowItem: file: lib/Circle/WindowItem.pm version: '0.173320' requires: Attribute::Storage: '0.09' Class::Method::Modifiers: '0' Data::Dump: '0' File::Basename: '0' File::Path: '0' File::ShareDir: '1.00' IO::Async::Listener: '0.64' IO::Async::Loop: '0.37' Module::Pluggable: '4.1' Net::Async::IRC: '0.10' Net::Async::Tangence::Server: '0.13' String::Tagged: '0.11' Struct::Dumb: '0' Tangence::Message: '0.11' Tangence::Object: '0.18' Tangence::Registry: '0.20' YAML: '0' perl: '5.010' resources: license: http://dev.perl.org/licenses/ version: '0.173320' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' circle-be-0.173320/README000444001750001750 200713207602007 13330 0ustar00leoleo000000000000NAME Circle - server backend for the Circle application host QUESTIONS How do I connect to freenode.net #perl and identify with NickServ # in Global tab /networks add -type irc Freenode # in Freenode tab /set nick YourNickHere /servers add irc.freenode.net -ident yournamehere -pass secretpasswordhere /connect # Don't forget to /config save How do I get notifications whenever someone uses the word perl in a channel that isn't on magnet or freenode#perl /rules add input not(channel("#perl")) matches("perl"): highlight Rules are network-specific so just don't do that on Magnet. How do I set up a command to ban the hostmask for a given nick in the current channel for 24h You'll have to read the hostmask of the user specifically, but then /mode +b ident@host.name.here /delay 86400 mode -b ident@host.name.here Note the lack of / on the inner mode to delay AUTHOR Paul Evans circle-be-0.173320/circle-be000555001750001750 6613207602007 14166 0ustar00leoleo000000000000#!/bin/sh exec perl -Mblib blib/script/circle-be "$@" circle-be-0.173320/bin000755001750001750 013207602007 13064 5ustar00leoleo000000000000circle-be-0.173320/bin/circle-be000555001750001750 503013207602007 14772 0ustar00leoleo000000000000#!/usr/bin/perl # You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2010 -- leonerd@leonerd.org.uk use strict; use warnings; use Circle; use IO::Async::Loop 0.37; use IO::Async::Stream; use Errno qw( ECONNREFUSED ); use Getopt::Long; # Optional but handy eval { require Devel::Confess } and Devel::Confess->import; GetOptions( 'p|port=i' => \my $PORT, 's|socket=s' => \my $SOCKPATH, 'stdio' => \my $STDIO, 'C|config=s' => \my $CONFIG, 'help' => sub { usage(0) }, ) or usage(1); sub usage { my ( $exitcode ) = @_; print { $exitcode ? \*STDERR : \*STDOUT } <<'EOF'; circle-be [options...] Options: --port, -p PORT Listen on given TCP port --socket, -s SOCKET Listen on given UNIX socket path --stdio Listen on STDIN/STDOUT --config, -C FILE Override path to config file EOF exit $exitcode; } defined($PORT) + defined($SOCKPATH) + defined($STDIO) > 1 and die "Cannot specify more than one of --port, --socket and --stdio\n"; defined($PORT) or defined($SOCKPATH) or defined($STDIO) or usage(1); my $loop = IO::Async::Loop->new(); my $circle = Circle->new( loop => $loop, config => $CONFIG, ); if( defined $PORT ) { $circle->listen( addr => { family => 'inet', socktype => 'stream', port => $PORT, ip => '0.0.0.0', # fscking.... }, on_fail => sub { print STDERR "Cannot $_[0] - $_[-1]\n"; }, on_listen_error => sub { print STDERR "Cannot listen\n"; }, ); } elsif( defined $SOCKPATH ) { if( -e $SOCKPATH ) { if( IO::Socket::UNIX->new( Peer => $SOCKPATH ) ) { # success - existing server running die "Unable to listen on $SOCKPATH - an existing server is running\n"; } elsif( $! == ECONNREFUSED ) { # OK - no server listening unlink $SOCKPATH or die "Cannot unlink $SOCKPATH - $!\n"; } else { die "Unable to probe if $SOCKPATH is in use - $!\n"; } } $circle->listen( addr => { family => 'unix', socktype => 'stream', path => $SOCKPATH, }, on_fail => sub { print STDERR "Cannot $_[0] - $_[-1]\n"; }, on_listen_error => sub { print STDERR "Cannot listen\n"; }, ); } elsif( $STDIO ) { $circle->on_stream( IO::Async::Stream->new_for_stdio ); } $SIG{__WARN__} = sub { local $SIG{__WARN__}; # disable during itself to avoid looping $circle->warn( @_ ); }; $SIG{PIPE} = "IGNORE"; $loop->run; circle-be-0.173320/bin/circle-parse-eventdump000555001750001750 304613207602007 17530 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use File::Slurp qw( slurp ); use Getopt::Long; use POSIX qw( strftime ); use Text::Balanced qw( extract_bracketed ); use YAML qw( LoadFile ); GetOptions( 'timestamp|t=s' => \(my $TIMESTAMP = "%Y/%m/%d %H:%M:%S"), 'theme=s' => \(my $THEME = "../circle-fe-term/share/circle-fe-term.theme"), # TODO ) or exit 1; my $filename = shift @ARGV; defined $filename or die "Require a filename\n"; my %theme; { foreach ( slurp $THEME ) { next unless m/^(.*?)=(.*)$/; $theme{$1} = $2; } } my $events = LoadFile( $filename ); foreach my $ev ( @$events ) { my ( $type, $time, $args ) = @$ev; my $timestamp = strftime $TIMESTAMP, localtime $time; my $template = $theme{$type} or (print "<>\n"), next; my $text = process( $template, $args ); print "$timestamp: $text\n"; } sub process { my ( $template, $args ) = @_; my $ret = ""; while( length $template ) { if( $template =~ s/^\$(\w+)// ) { my $val = $args->{$1}; my @parts = ref $val eq "ARRAY" ? @$val : ( $val ); foreach my $part ( @parts ) { $ret .= ref $part eq "ARRAY" ? $part->[0] : $part; } } elsif( $template =~ m/^{/ ) { my $piece = extract_bracketed( $template, "{}" ); s/^{//, s/}$// for $piece; my ( $code, $content ) = split( m/ /, $piece, 2 ); $ret .= process( $content, $args ); } else { $template =~ s/^([^\$\{]+)//; $ret .= $1; } } return $ret; } circle-be-0.173320/bin/circle-parse-yamllog000555001750001750 466213207602007 17172 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use File::Slurp qw( slurp ); use Getopt::Long; use POSIX qw( mktime strftime ); use POSIX::strptime qw( strptime ); use Text::Balanced qw( extract_bracketed ); use YAML qw( LoadFile ); GetOptions( 'timestamp|t=s' => \(my $TIMESTAMP = "%Y/%m/%d %H:%M:%S"), 'theme=s' => \(my $THEME = "../circle-fe-term/share/circle-fe-term.theme"), # TODO ) or exit 1; my $filename = shift @ARGV; defined $filename or die "Require a filename\n"; my %theme; { foreach ( slurp $THEME ) { next unless m/^(.*?)=(.*)$/; $theme{$1} = $2; } } open my $inh, "<", $filename or die "Cannot read $filename - $!"; my $headline = <$inh>; my ( $start, $items, $timefmt ) = $headline =~ m/^!LOG START="([^"]+)" ITEMS="([^"]+)" TIMESTAMP_FMT="([^"]+)"$/ or die "Unable to parse headline - is this a yamllog file?\n"; # The first string part of each log line is formatted as per $timefmt, but # we'll need to know how many spaces it contains in order to strip it my $timere = join " +", ( "\\S+" ) x ( 1 + ( () = $timefmt =~ m/ +/g ) ); $timere = qr/$timere/; my @startt = ( strptime $start, "%Y/%m/%d %H:%M:%S" )[0..5]; while( <$inh> ) { my $line = $_; chomp $line; my ( $time, $type, $data ) = $line =~ m/^($timere) +(\S+) +(.*)$/ or die "Unparseable line> $line\n"; my @thist = strptime $time, $timefmt; $thist[$_] //= $startt[$_] for 0 .. 5; $time = mktime @thist[0..5]; # YAML::Load doesn't like flow forms at toplevel. Lets cheat $data = YAML::Load( "data: $data" )->{data}; my $timestamp = strftime $TIMESTAMP, localtime $time; my $template = $theme{$type} or (print "<>\n"), next; my $text = process( $template, $data ); print "$timestamp: $text\n"; } sub process { my ( $template, $args ) = @_; my $ret = ""; while( length $template ) { if( $template =~ s/^\$(\w+)// ) { my $val = $args->{$1}; my @parts = ref $val eq "ARRAY" ? @$val : ( $val ); foreach my $part ( @parts ) { $ret .= ref $part eq "ARRAY" ? $part->[0] : $part; } } elsif( $template =~ m/^{/ ) { my $piece = extract_bracketed( $template, "{}" ); s/^{//, s/}$// for $piece; my ( $code, $content ) = split( m/ /, $piece, 2 ); $ret .= process( $content, $args ); } else { $template =~ s/^([^\$\{]+)//; $ret .= $1; } } return $ret; } circle-be-0.173320/lib000755001750001750 013207602007 13062 5ustar00leoleo000000000000circle-be-0.173320/lib/Circle.pm000444001750001750 602213207602007 14756 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk package Circle; use strict; use warnings; use base qw( Net::Async::Tangence::Server ); IO::Async::Listener->VERSION( '0.64' ); # {handle_constructor} Net::Async::Tangence::Server->VERSION( '0.13' ); # Future-returning API our $VERSION = '0.173320'; use Carp; use Tangence::Registry 0.20; # Support for late-loading classes use File::ShareDir qw( module_file ); use IO::Async::OS; require Circle::RootObj; # must be late-bound, after $VERSION is set =head1 NAME C - server backend for the C application host =cut sub new { my $class = shift; my %args = @_; my $loop = $args{loop} or croak "Need a loop"; my $registry = Tangence::Registry->new( tanfile => module_file( __PACKAGE__, "circle.tan" ), ); my $rootobj = $registry->construct( "Circle::RootObj", loop => $loop ); $rootobj->id == 1 or die "Assert failed: root object does not have ID 1"; my $self = $class->SUPER::new( registry => $registry, ); $loop->add( $self ); $self->{rootobj} = $rootobj; return $self; } sub make_local_client { my $self = shift; my $loop = $self->loop; my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!"; # Internal hackery; stolen from IaListener my $acceptor = $self->acceptor; my $handle = $self->{handle_constructor}->( $self ); $S1->blocking( 0 ); $handle->set_handle( $S1 ); $self->on_accept( $handle ); require Net::Async::Tangence::Client; my $client = Net::Async::Tangence::Client->new( handle => $S2, identity => "test_client", ); $loop->add( $client ); return $client; } sub new_with_client { my $class = shift; my $self = $class->new( @_ ); my $client = $self->make_local_client; return ( $self, $client ); } sub warn { my $self = shift; my $text = join " ", @_; chomp $text; my $rootobj = $self->{rootobj}; $rootobj->push_displayevent( warning => { text => $text } ); $rootobj->bump_level( 2 ); } =head1 QUESTIONS =head2 How do I connect to freenode.net #perl and identify with NickServ # in Global tab /networks add -type irc Freenode # in Freenode tab /set nick YourNickHere /servers add irc.freenode.net -ident yournamehere -pass secretpasswordhere /connect # Don't forget to /config save =head2 How do I get notifications whenever someone uses the word perl in a channel that isn't on magnet or freenode#perl /rules add input not(channel("#perl")) matches("perl"): highlight Rules are network-specific so just don't do that on Magnet. =head2 How do I set up a command to ban the hostmask for a given nick in the current channel for 24h You'll have to read the hostmask of the user specifically, but then /mode +b ident@host.name.here /delay 86400 mode -b ident@host.name.here Note the lack of C on the inner C to C =head1 AUTHOR Paul Evans =cut 0x55AA; circle-be-0.173320/lib/Circle000755001750001750 013207602007 14263 5ustar00leoleo000000000000circle-be-0.173320/lib/Circle/Collection.pm000444001750001750 2325413207602007 17077 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk package Circle::Collection; use strict; use warnings; our $VERSION = '0.173320'; use Carp; require attributes; use Attribute::Storage qw( apply_subattrs_for_pkg ); use Class::Method::Modifiers qw( install_modifier ); # A template role to merge sub import { my $pkg = shift; my %args = @_; my $caller = caller; my $name = $args{name} or croak "Need a collection name"; my $attrs = $args{attrs} or croak "Need attrs"; ref $attrs eq "ARRAY" or croak "Expected 'attrs' to be an ARRAY"; my $desc2 = $args{desc_plural} || $name; my $desc1 = $args{desc_single} || do { $_ = $name; s/s$//; $_ }; my $storage = $args{storage} or croak "Need a storage type"; my $config = $args{config}; # Now parse it down to several fields my @attrs_all; my @attrs_persisted; my %attrs; for( my $i = 0; $i < @$attrs; $i += 2 ) { my $name = $attrs->[$i]; my $a = $attrs->[$i+1]; push @attrs_all, $name; push @attrs_persisted, $name unless $a->{transient}; $attrs{$name} = $a; } my $keyattr = $attrs_all[0]; my %commands; %commands = %{ $args{commands} } if $args{commands}; # Data access code my ( $method_list, $method_get, $method_set, $method_add, $method_del ); if( ref $storage eq "HASH" ) { $method_list = $storage->{list}; $method_get = $storage->{get}; $method_set = $storage->{set}; $method_add = $storage->{add}; $method_del = $storage->{del}; } elsif( $storage eq "methods" ) { $method_list = "${name}_list"; $method_get = "${name}_get"; $method_set = "${name}_set"; $method_add = "${name}_add"; $method_del = "${name}_del"; } elsif( $storage eq "array" ) { $method_list = sub { my $self = shift; return @{ $self->{$name} } }; $method_get = sub { my $self = shift; my ( $key ) = @_; return ( grep { $_->{$keyattr} eq $key } @{ $self->{$name} } )[0]; }; $method_add = sub { my $self = shift; my ( $key, $item ) = @_; # TODO: something with key push @{ $self->{$name} }, $item; }; $method_del = sub { my $self = shift; my ( $key, $item ) = @_; my $items = $self->{$name}; my ( $idx ) = grep { $items->[$_] == $item } 0 .. $#$items; return 0 unless defined $idx; splice @$items, $idx, 1, (); return 1; }; } else { croak "Unrecognised storage type $storage"; } # Manipulation commands unless( exists $commands{list} ) { defined $method_list or croak "No list method defined for list subcommand"; $commands{list} = apply_subattrs_for_pkg( $caller, Command_description => qq("List the $desc2"), Command_subof => qq('$name'), Command_default => qq(), sub { my $self = shift; my ( $cinv ) = @_; my @items = $self->$method_list; unless( @items ) { $cinv->respond( "No $desc2" ); return; } my @table; foreach my $item ( @items ) { my @shown_item; foreach my $attr ( @attrs_all ) { my $value = $item->{$attr}; push @shown_item, exists $attrs{$attr}{show} ? $attrs{$attr}{show}->( local $_ = $value ) : $value; } push @table, \@shown_item; } $cinv->respond_table( \@table, headings => \@attrs_all ); return; } ); } my @opts_add; my @opts_mod; foreach ( @attrs_persisted ) { next if $_ eq $keyattr; my $desc = $attrs{$_}{desc} || $_; $desc .= qq[ (default \\"$attrs{$_}{default}\\")] if exists $attrs{$_}{default}; push @opts_add, qq('$_=\$', desc => "$desc"); push @opts_mod, qq('$_=\$', desc => "$desc"), qq('no-$_=+', desc => "remove $_") unless $attrs{$_}{nomod}; } unless( exists $commands{add} ) { defined $method_add or croak "No add method defined for add subcommand"; $commands{add} = apply_subattrs_for_pkg( $caller, Command_description => qq("Add a $desc1"), Command_subof => qq('$name'), Command_arg => qq('$keyattr'), ( map { +Command_opt => $_ } @opts_add ), sub { my $self = shift; my ( $key, $opts, $cinv ) = @_; if( $self->$method_get( $key ) ) { $cinv->responderr( "Already have a $desc1 '$key'" ); return; } my $item = { $keyattr => $key }; exists $attrs{$_}{default} and $item->{$_} = $attrs{$_}{default} for @attrs_persisted; defined $opts->{$_} and $item->{$_} = $opts->{$_} for @attrs_persisted; unless( eval { $self->$method_add( $key, $item ); 1 } ) { my $err = "$@"; chomp $err; $cinv->responderr( "Cannot add $desc1 '$key' - $err" ); return; } $cinv->respond( "Added $desc1 '$key'" ); return; } ); } unless( exists $commands{mod} ) { defined $method_get or croak "No get method defined for mod subcommand"; $commands{mod} = apply_subattrs_for_pkg( $caller, Command_description => qq("Modify an existing $desc1"), Command_subof => qq('$name'), Command_arg => qq('$keyattr'), ( map { +Command_opt => $_ } @opts_mod ), sub { my $self = shift; my ( $key, $opts, $cinv ) = @_; my $item = $self->$method_get( $key ); unless( $item ) { $cinv->responderr( "No such $desc1 '$key'" ); return; } my %mod; exists $opts->{$_} and $mod{$_} = $opts->{$_} for @attrs_persisted; exists $opts->{"no-$_"} and $mod{$_} = $attrs{$_}{default} for @attrs_persisted; if( $method_set ) { $self->$method_set( $key, \%mod ); } else { $item->{$_} = $mod{$_} for keys %mod; } $cinv->respond( "Modified $desc1 '$key'" ); return; } ); } unless( exists $commands{del} ) { defined $method_del or croak "No del method defined for del subcommand"; $commands{del} = apply_subattrs_for_pkg( $caller, Command_description => qq("Delete a $desc1"), Command_subof => qq('$name'), Command_arg => qq('$keyattr'), sub { my $self = shift; my ( $key, $cinv ) = @_; my $item = $self->$method_get( $key ); unless( $item ) { $cinv->responderr( "No such $desc1 '$key'" ); return; } unless( eval { $self->$method_del( $key, $item ); 1 } ) { my $err = "$@"; chomp $err; $cinv->responderr( "Cannot delete $desc1 '$key' - $err" ); return; } $cinv->respond( "Removed $desc1 '$key'" ); return; } ); } # Now delete present-but-undef ones; these are where the caller vetoed the # above autogeneration defined $commands{$_} or delete $commands{$_} for keys %commands; my %subs; $subs{"command_${name}_$_"} = $commands{$_} for keys %commands; $subs{"command_${name}"} = apply_subattrs_for_pkg( $caller, Command_description => qq("Display or manipulate $desc2"), # body matters not but it needs to be a cloned closure do { my $dummy; sub { undef $dummy } } ); { no strict 'refs'; *{"${caller}::$_"} = $subs{$_} for keys %subs; } if( !defined $config or $config ) { my $config_type = $config->{type} || "array"; my $type_array = $config_type eq "array"; my $type_hash = $config_type eq "hash"; $type_array or $type_hash or die "Expected config type either 'array' or 'hash'"; # Optional config-related methods my $method_store = $config->{store}; my $method_load = $config->{load}; # Configuration load/store install_modifier $caller, after => load_configuration => sub { my $self = shift; my ( $ynode ) = @_; my $ynodes = $ynode->{$name} or return; foreach my $this ( $type_array ? @$ynodes : keys %$ynodes ) { my $item = {}; my $n = $type_array ? $this : $ynodes->{$this}; $item->{$_} = $n->{$_} for @attrs_persisted; $item->{$keyattr} = $this if $type_hash; $self->$method_add( $item->{$keyattr}, $item ); if( ref $method_load or $method_load && $self->can( $method_load ) ) { $self->$method_load( $item->{$keyattr}, $n ); } } }; install_modifier $caller, after => store_configuration => sub { my $self = shift; my ( $ynode ) = @_; my $ynodes = $ynode->{$name} ||= $type_array ? [] : YAML::Node->new({}); $type_array ? ( @$ynodes = () ) : ( %$ynodes = () ); foreach my $item ( $self->$method_list ) { my $n = YAML::Node->new({}); defined $item->{$_} and $n->{$_} = $item->{$_} for @attrs_persisted; if( ref $method_store or $method_store && $self->can( $method_store ) ) { $self->$method_store( $item->{$keyattr}, $n ); } $type_array ? ( push @$ynodes, $n ) : do { $ynodes->{$n->{$keyattr}} = $n; delete $n->{$keyattr} }; } }; } } 0x55AA; circle-be-0.173320/lib/Circle/Command.pm000444001750001750 512213207602007 16334 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk package Circle::Command; use strict; use warnings; our $VERSION = '0.173320'; use Attribute::Storage qw( get_subattrs get_subattr find_subs_with_attr ); require mro; sub _find_commands { my ( $obj, $cinv, $containedby ) = @_; my @ret; my %commands; while( $obj ) { my %subs = find_subs_with_attr( mro::get_linear_isa( ref $obj ), "Command_description", matching => qr/^command_/, ); foreach my $name ( keys %subs ) { ( my $commandname = $name ) =~ s/^command_//; my $cv = $subs{$name}; next if $commands{$commandname}; my $subof = get_subattr( $cv, "Command_subof" ); next if $containedby and !$subof or !$containedby and $subof or $containedby and $subof and $containedby ne $subof; my $attrs = get_subattrs( $cv ); $commands{$commandname} = 1; push @ret, __PACKAGE__->new( %$attrs, name => $commandname, obj => $obj, cv => $cv, ); } # Collect in parent too $obj = $obj->can( "commandable_parent" ) && $obj->commandable_parent( $cinv ); } return @ret; } sub root_commands { my $class = shift; my ( $cinv ) = @_; return map { $_->name => $_ } _find_commands( $cinv->invocant, $cinv, undef ); } # Object stuff sub new { my $class = shift; my %attrs = @_; $attrs{name} =~ s/_/ /g; return bless \%attrs, $class; } sub sub_commands { my $self = shift; my ( $cinv ) = @_; return map { $_->shortname => $_ } _find_commands( $cinv->invocant, $cinv, $self->name ); } sub name { my $self = shift; return $self->{name}; } sub shortname { my $self = shift; ( split m/ /, $self->name )[-1]; } sub is_default { my $self = shift; return $self->{Command_default}; } sub desc { my $self = shift; return $self->{Command_description}[0] || "[no description]"; } sub detail { my $self = shift; return $self->{Command_description}[1]; } sub args { my $self = shift; return unless $self->{Command_arg}; return @{ $self->{Command_arg} }; } sub opts { my $self = shift; return $self->{Command_opt}; } sub default_sub { my $self = shift; my ( $cinv ) = @_; my %subs = $self->sub_commands( $cinv ); my @defaults = grep { $_->is_default } values %subs; return $defaults[0] if @defaults == 1; # Only if it's unique return; } sub invoke { my $self = shift; $self->{cv}->( $self->{obj}, @_ ); } 0x55AA; circle-be-0.173320/lib/Circle/CommandInvocation.pm000444001750001750 274713207602007 20400 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2010 -- leonerd@leonerd.org.uk package Circle::CommandInvocation; use strict; use warnings; our $VERSION = '0.173320'; use Scalar::Util qw( weaken ); sub new { my $class = shift; my ( $text, $connection, $invocant ) = @_; $text =~ s/^\s+//; # Weaken the connection to ensure that this object doesn't hold on to the # connection longer than required my $self = bless [ $text, $connection, $invocant ], $class; weaken( $self->[1] ); return $self; } sub nest { my $self = shift; my ( $text ) = @_; return (ref $self)->new( $text, $self->connection, $self->invocant ); } sub connection { my $self = shift; return $self->[1]; } sub invocant { my $self = shift; return $self->[2]; } sub peek_token { my $self = shift; if( $self->[0] =~ m/^"/ ) { $self->[0] =~ m/^"(.*)"/ and return $1; } else { $self->[0] =~ m/^(\S+)/ and return $1; } return undef; } sub pull_token { my $self = shift; if( $self->[0] =~ m/^"/ ) { $self->[0] =~ s/^"(.*)"\s*// and return $1; } else { $self->[0] =~ s/^(\S+)\s*// and return $1; } return undef; } sub peek_remaining { my $self = shift; return $self->[0]; } # delegate these to invocant foreach my $method (qw( respond respondwarn responderr respond_table )) { no strict 'refs'; *$method = sub { shift->invocant->$method( @_ ) }; } 0x55AA; circle-be-0.173320/lib/Circle/Commandable.pm000444001750001750 2204413207602007 17202 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2012 -- leonerd@leonerd.org.uk package Circle::Commandable; use strict; use warnings; our $VERSION = '0.173320'; use Carp; use Attribute::Storage 0.06 qw( get_subattr get_subattrs ); use Circle::Command; use Circle::CommandInvocation; use Circle::Widget::Entry; ############################################# ### Attribute handlers for command_* subs ### ############################################# sub Command_description :ATTR(CODE) { my $class = shift; my ( $text ) = @_; my ( $brief, $detail ) = split( m/\n/, $text, 2 ); return [ $brief, $detail ]; } sub Command_arg :ATTR(CODE,MULTI) { my $class = shift; my ( $args, $name, %spec ) = @_; # Some things are only allowed on the last argument. Check none of these # apply to the previous one my $prev = $args ? $args->[-1] : undef; if( $prev ) { $prev->{eatall} and croak "Cannot have another argument after an eatall"; $prev->{collect} and croak "Cannot have another argument after a collect"; $prev->{trail} and croak "Cannot have another argument after a trail"; } my $optional = $name =~ s/\?$//; # No error if this is missing my %arg = ( name => uc $name, optional => $optional, eatall => delete $spec{eatall}, # This argument consumes all the remaining text in one string collect => delete $spec{collect}, # This argument collects all the non-option tokens in an ARRAY ref ); $arg{eatall} and $arg{collect} and croak "Cannot eatall and collect"; keys %spec and croak "Unrecognised argument specification keys: ".join( ", ", keys %spec ); my $trail = 0; if( $name eq "..." ) { $arg{trail} = 1; } else { $name =~ m/\W/ and croak "Cannot use $name as an argument name"; } push @$args, \%arg; return $args; } sub Command_opt :ATTR(CODE,MULTI) { my $class = shift; my ( $opts, $name, %spec ) = @_; my %opt = ( desc => delete $spec{desc}, ); keys %spec and croak "Unrecognised option specification keys: ".join( ", ", keys %spec ); $name =~ s/=(.*)$// or croak "Cannot recognise $name as an option spec"; $opt{type} = $1; $opt{type} =~ m/^[\$\+]$/ or croak "Cannot recognise $opt{type} as an option type"; $opts->{$name} = \%opt; return $opts; } sub Command_subof :ATTR(CODE) { my $class = shift; my ( $parent ) = @_; return $parent; } sub Command_default :ATTR(CODE) { return 1; # Just a boolean } sub do_command { my $self = shift; my ( $cinv ) = @_; my $cmd = $cinv->pull_token; my $command = undef; my %commands = Circle::Command->root_commands( $cinv ); while( keys %commands and $cmd ||= $cinv->pull_token ) { unless( exists $commands{$cmd} ) { $cinv->responderr( $command ? $command->name . " has no sub command $cmd" : "No such command $cmd" ); return; } $command = $commands{$cmd}; %commands = $command->sub_commands( $cinv ); undef $cmd; } while( keys %commands ) { my $subcmd = $command->default_sub( $cinv ); if( !$subcmd ) { # No default subcommand - issue help on $command instead my $helpinv = $cinv->nest( "help " . $command->name ); return $self->do_command( $helpinv ); } $command = $subcmd; %commands = $command->sub_commands( $cinv ); } my $cname = $command->name; my @args; my %opts; my @argspec = $command->args; my $optspec = $command->opts; my $argindex = 0; my $no_more_opts; while( length $cinv->peek_remaining ) { if( $cinv->peek_token eq "--" ) { $cinv->pull_token; $no_more_opts++; next; } if( !$no_more_opts and $cinv->peek_remaining =~ m/^-/ ) { # An option my $optname = $cinv->pull_token; $optname =~ s/^-//; $optspec and exists $optspec->{$optname} or return $cinv->responderr( "$cname: unrecognised option $optname" ); my $optvalue; if( $optspec->{$optname}{type} eq '$' ) { $optvalue = $cinv->pull_token; defined $optvalue or return $cinv->responderr( "$cname: option $optname require a value" ); } else { $optvalue = 1; } $opts{$optname} = $optvalue; } else { return $cinv->responderr( "$cname: Too many arguments" ) if !@argspec or $argindex >= @argspec; my $a = $argspec[$argindex]; if( $a->{eatall} ) { push @args, $cinv->peek_remaining; $argindex++; last; } elsif( $a->{collect} ) { # If this is the first one, $args[-1] won't be an ARRAY ref push @args, [] unless ref $args[-1]; push @{ $args[-1] }, $cinv->pull_token; } elsif( $a->{trail} ) { last; } else { push @args, $cinv->pull_token; $argindex++; } } } while( $argindex < @argspec ) { my $a = $argspec[$argindex++]; if( $a->{collect} ) { push @args, [] unless ref $args[-1]; last; } elsif( $a->{trail} ) { last; } $a->{optional} or return $cinv->responderr( "$cname: expected $a->{name}" ); push @args, undef; } push @args, \%opts if $optspec; push @args, $cinv; my @response = eval { $command->invoke( @args ) }; if( $@ ) { my $text = $@; chomp $text; $cinv->responderr( $text ); } else { $cinv->respond( $_ ) foreach @response; } } sub command_help : Command_description("Display help on a command") : Command_arg('command?') : Command_arg('...') { my $self = shift; my ( $cmd, $cinv ) = @_; my $command = undef; my %commands = Circle::Command->root_commands( $cinv ); if( !defined $cmd ) { my $class = ref $self || $self; $cinv->respond( "Available commands for $class:" ); } while( ( $cmd ||= $cinv->pull_token ) ) { unless( exists $commands{$cmd} ) { $cinv->responderr( $command ? $command->name . " has no sub command $cmd" : "No such command $cmd" ); return; } $command = $commands{$cmd}; %commands = $command->sub_commands( $cinv ); undef $cmd; } if( $command ) { $cinv->respond( "/" . $command->name . " - " . $command->desc ); } if( keys %commands ) { $cinv->respond( "Usage: " . $command->name . " SUBCMD ..." ) if $command; my @table; foreach my $sub ( map { $commands{$_} } sort keys %commands ) { my $subname; # bold function name if it's default if( $sub->is_default ) { $subname = Circle::TaggedString->new( " /" . $sub->name ); $subname->apply_tag( 0, $subname->length, b => 1 ); } else { $subname = " /" . $sub->name; } push @table, [ $subname, $sub->desc ]; } $cinv->respond_table( \@table, colsep => " - ", headings => [ "Command", "Description" ] ); return; } my @argdesc; foreach my $a ( $command->args ) { my $name = $a->{name}; $name .= "..." if $a->{eatall}; $name .= "+" if $a->{collect}; $name = "[$name]" if $a->{optional}; push @argdesc, $name; } $cinv->respond( "Usage: " . join( " ", $command->name, @argdesc ) ); if( my $opts = $command->opts ) { $cinv->respond( "Options:" ); my @table; foreach my $opt ( sort keys %$opts ) { my $opttype = $opts->{$opt}{type}; my $desc = defined $opts->{$opt}{desc} ? $opts->{$opt}{desc} : ""; push @table, [ " -$opt" . ( $opttype eq '$' ? " VALUE" : "" ), $desc ]; } $cinv->respond_table( \@table, headings => [ "Option", "Description" ] ); } if( my $detail = $command->detail ) { $cinv->respond( "" ); $cinv->respond( $_ ) for split( m/\n/, $detail ); } return; } sub method_do_command { my $self = shift; my ( $ctx, $command ) = @_; my $cinv = Circle::CommandInvocation->new( $command, $ctx->stream, $self ); $self->do_command( $cinv ); } ### # Widget ### sub get_widget_commandentry { my $self = shift; return $self->{widget_commandentry} if defined $self->{widget_commandentry}; my $registry = $self->{registry}; my $widget = $registry->construct( "Circle::Widget::Entry", autoclear => 1, focussed => 1, history => 100, # TODO on_enter => sub { my ( $text, $ctx ) = @_; if( $text =~ m{^/} ) { substr( $text, 0, 1 ) = ""; my $cinv = Circle::CommandInvocation->new( $text, $ctx->stream, $self ); $self->do_command( $cinv ); } elsif( $self->can( "enter_text" ) ) { $self->enter_text( $text ); } else { $self->responderr( "Cannot enter raw text here" ); } }, ); return $self->{widget_commandentry} = $widget; } 0x55AA; circle-be-0.173320/lib/Circle/Configurable.pm000444001750001750 1650713207602007 17407 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk package Circle::Configurable; use strict; use warnings; use base qw( Circle::Commandable ); our $VERSION = '0.173320'; use Carp; use Attribute::Storage qw( get_subattr get_subattrs apply_subattrs_for_pkg find_subs_with_attr ); use Data::Dump qw( pp ); require mro; ############################################# ### Attribute handlers for setting_* subs ### ############################################# my %setting_types = ( str => {}, int => { check => sub { m/^\d+$/ }, }, bool => { parse => sub { return 1 if lc $_ eq "true" or lc $_ eq "on" or $_ eq "1"; return 0 if lc $_ eq "false" or lc $_ eq "off" or $_ eq "0"; die; }, print => sub { $_ ? "true" : "false" }, }, ); sub Setting_description :ATTR(CODE) { my $class = shift; my ( $text ) = @_; return $text; } sub Setting_type :ATTR(CODE) { my $class = shift; my ( $typename ) = @_; exists $setting_types{$typename} or croak "Not a recognised type name '$typename'"; return $setting_types{$typename}; } sub Setting_default :ATTR(CODE) { my $class = shift; my ( $value ) = @_; return $value; } sub Setting_inheritable :ATTR(CODE) { return 1; } sub APPLY_Setting { my $class = shift; my ( $name, %args ) = @_; my $storage = $args{storage} || $name; no strict 'refs'; *{"${class}::setting_$name"} = apply_subattrs_for_pkg $class, Setting_description => qq("\Q$args{description}\E"), Setting_type => qq("\Q$args{type}\E"), ( exists $args{default} ? ( Setting_default => pp($args{default}) ) : () ), sub { my $self = shift; my ( $newvalue ) = @_; $self->{$storage} = $newvalue if @_; return $self->{$storage}; }; } sub APPLY_Inheritable_Setting { my $class = shift; my ( $name, %args ) = @_; my $storage = $args{storage} || $name; my $setting = "setting_$name"; no strict 'refs'; *{"${class}::setting_$name"} = apply_subattrs_for_pkg $class, Setting_description => qq("\Q$args{description}\E"), Setting_type => qq("\Q$args{type}\E"), Setting_inheritable => qq(), ( exists $args{default} ? ( Setting_default => pp($args{default}) ) : () ), sub { my $self = shift; my ( $newvalue ) = @_; $self->{$storage} = $newvalue if @_; return $self->{$storage} if defined $self->{$storage}; if( my $parent = $self->parent ) { return $parent->$setting; } else { return undef; } }; *{"${class}::_setting_${name}_inherits"} = sub { my $self = shift; return $self->parent && !defined $self->{$storage}; }; } sub _get_settings { my $self = shift; my $class = ref $self || $self; my %subs = find_subs_with_attr( mro::get_linear_isa( $class ), "Setting_description", matching => qr/^setting_/ ); my %settings; foreach my $name ( keys %subs ) { ( my $settingname = $name ) =~ s/^setting_//; my $cv = $subs{$name}; my $attrs = $settings{$settingname} = get_subattrs( $cv ); m/^Setting_(.*)$/ and $attrs->{$1} = delete $attrs->{$_} for keys %$attrs; } return \%settings; } sub command_set : Command_description("Display or manipulate configuration settings") : Command_arg('setting?') : Command_arg('value?') : Command_opt('inherit=+', desc => "Inherit value from parent") : Command_opt('help=+', desc => "Display help on setting(s)") : Command_opt('values=+', desc => "Display value of each setting") { my $self = shift; my ( $setting, $newvalue, $opts, $cinv ) = @_; my $opt_inherit = $opts->{inherit}; my $opt_help = $opts->{help}; my $opt_values = $opts->{values}; if( !defined $setting ) { my $settings = $self->_get_settings; keys %$settings or $cinv->respond( "No settings exist" ), return; if( $opt_values ) { my @table; foreach my $settingname ( sort keys %$settings ) { $setting = $settings->{$settingname}; my $curvalue = $self->can( "setting_$settingname" )->( $self ); if( $setting->{type}->{print} ) { $curvalue = $setting->{type}->{print}->( local $_ = $curvalue ); } if( $setting->{inheritable} && $self->can( "_setting_${settingname}_inherits" )->( $self ) ) { $settingname .= " [I]"; } push @table, [ $settingname, ( defined $curvalue ? $curvalue : "" ), ]; } $self->respond_table( \@table, colsep => ": ", headings => [ "Setting", "Value" ] ); } else { my @table; foreach my $settingname ( sort keys %$settings ) { my $setting = $settings->{$settingname}; push @table, [ $settingname, ( $setting->{Setting_description} || "[no description]" ) ]; } $cinv->respond_table( \@table, colsep => " - ", headings => [ "Setting", "Description" ] ); } return; } my $cv = $self->can( "setting_$setting" ); if( !defined $cv ) { $cinv->responderr( "No such setting $setting" ); return; } if( $opt_help ) { my $description = get_subattr( $cv, 'Setting_description' ) || "[no description]"; $cinv->respond( "$setting - $description" ); return; } my $type = get_subattr( $cv, 'Setting_type' ); my $curvalue; if( defined $newvalue or $opt_inherit ) { if( !$opt_inherit and $type->{check} ) { local $_ = $newvalue; $type->{check}->( $newvalue ) or $cinv->responderr( "'$newvalue' is not a valid value for $setting" ), return; } if( !$opt_inherit and $type->{parse} ) { local $_ = $newvalue; eval { $newvalue = $type->{parse}->( $newvalue ); 1 } or $cinv->responderr( "'$newvalue' is not a valid value for $setting" ), return; } undef $newvalue if $opt_inherit; $curvalue = $cv->( $self, $newvalue ); } else { $curvalue = $cv->( $self ); } if( $type->{print} ) { local $_ = $curvalue; $curvalue = $type->{print}->( local $_ = $curvalue ); } if( defined $curvalue ) { $cinv->respond( "$setting: $curvalue" ); } else { $cinv->respond( "$setting is not set" ); } return; } sub get_configuration { my $self = shift; my $ynode = YAML::Node->new({}); $self->store_configuration( $ynode ); return $ynode; } sub load_configuration { my $self = shift; my ( $ynode ) = @_; foreach my $setting ( keys %{ $self->_get_settings } ) { my $cv = $self->can( "setting_$setting" ) or croak "$self has no setting $setting"; my $value = $ynode->{$setting}; if( !defined $value and defined( my $default = get_subattr( $cv, "Setting_default" ) ) ) { $value = $default; } $cv->( $self, $value ) if defined $value; } } sub store_configuration { my $self = shift; my ( $ynode ) = @_; foreach my $setting ( keys %{ $self->_get_settings } ) { my $cv = $self->can( "setting_$setting" ) or croak "$self has no setting $setting"; my $value = $cv->( $self ); $ynode->{$setting} = $value if defined $value; } } 0x55AA; circle-be-0.173320/lib/Circle/GlobalRules.pm000444001750001750 2360713207602007 17221 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2017 -- leonerd@leonerd.org.uk package Circle::GlobalRules; use strict; use warnings; our $VERSION = '0.173320'; use Text::Balanced qw( extract_delimited extract_quotelike ); use base qw( Circle::Rule::Store ); # for the attributes use Circle::TaggedString; sub unquote_qr { my $re = shift; $re = "$re"; # Perl tries to put (?-xism:RE) around our pattern. Lets attempt to remove # it if we can # Recent perls use (?^:RE) instead $re =~ s/^\(\?-xism:(.*)\)$/$1/; $re =~ s/^\(\?\^:(.*)\)$/$1/; return ( $2, $1 ) if $re =~ m/^\(\?([ixsm]*)-?[xism]*:(.*)\)$/; return ( $2, $1 ) if $re =~ m/^\(\?\^([ixsm]*):(.*)\)$/; # Failed. Lets just be safe then return ( $re, "" ); } # Not an object class. Instead, just a store of rule subs sub register { my ( $rulestore ) = @_; $rulestore->register_cond( matches => __PACKAGE__ ); $rulestore->register_action( rewrite => __PACKAGE__ ); $rulestore->register_action( format => __PACKAGE__ ); $rulestore->register_action( unformat => __PACKAGE__ ); $rulestore->register_action( level => __PACKAGE__ ); $rulestore->register_action( highlight => __PACKAGE__ ); } ###### CONDITIONS ### MATCHES sub parse_cond_matches : Rule_description("Look for regexp or substring matches in the text") : Rule_format('/regexp/ or "literal"') { shift; # class my ( $spec ) = @_; if( $spec =~ m{^/} ) { # Try to pull the flags my ( $content, $flags ) = $spec =~ m{^/(.*)/([i]*)$} or die "Unrecognised regexp string $spec\n"; return qr/$content/i if $flags eq "i"; return qr/$content/; } elsif( $spec =~ m{^"} ) { my ( $content ) = $spec =~ m{^"(.*)"$} or die "Unrecognised literal string $spec\n"; return qr/\Q$content/; } else { die "Unrecognised string type $spec"; } } sub deparse_cond_matches { shift; # class my ( $re ) = @_; my ( $pattern, $flags ) = unquote_qr( $re ); return "/$pattern/$flags"; } sub eval_cond_matches { shift; # class my ( $event, $results, $re ) = @_; defined( my $text = $event->{text} ) or return 0; $text = "$text"; # stringify a String::Tagged pos( $text ) = 0; my $matched; while( $text =~ m/$re/g ) { my @matchgroups; for ( 0 .. $#+ ) { my ( $start, $end ) = ( $-[$_], $+[$_] ); my $len = $end - $start; push @matchgroups, [ $start, $len ]; } $results->push_result( "matchgroups", \@matchgroups ); $matched = 1; } return $matched; } ###### ACTIONS ### REWRITE sub parse_action_rewrite : Rule_description("Rewrite text of the line or matched parts") : Rule_format('line|matches|match(number) "string"|s/pattern/replacement/') { shift; # class my ( $spec ) = @_; $spec =~ s/^(\w+)\s*// or die "Expected type as first argument\n"; my $type = $1; my $groupnum; if( $type eq "line" ) { $groupnum = -1; } elsif( $type eq "matches" ) { $groupnum = 0; } elsif( $type eq "match" ) { $spec =~ s/^\((\d+)\)\s*// or die "Expected match group number\n"; $groupnum = $1; } else { die "Unrecognised format type $type\n"; } my ( undef, $remains, undef, $op, $delim, $lhs, undef, undef, $rhs, undef, $mods ) = extract_quotelike( $spec ) or die 'Expected "string" or s/pattern/replacement/'; $spec = $remains; $op = $delim if $op eq ""; if( $op eq '"' ) { # Literal return ( $groupnum, literal => $lhs ); } elsif( $op eq "s" ) { # s/foo/bar/ my $global = $mods =~ s/g//; # TODO: Range check that mods contains only /ism return ( $groupnum, subst => qr/(?$mods:$lhs)/, $rhs, $global ); } else { die 'Expected "string" or s/pattern/replacement/'; } } sub deparse_action_rewrite { shift; # class my ( $groupnum, $kind, $lhs, $rhs, $global ) = @_; my $type = $groupnum == -1 ? "line" : $groupnum == 0 ? "matches" : "match($groupnum)"; if( $kind eq "literal" ) { return "$type \"$lhs\""; } elsif( $kind eq "subst" ) { my ( $pattern, $flags ) = unquote_qr( $lhs ); return "$type s/$pattern/$rhs/$flags" . ( $global ? "g" : "" ); } } sub eval_action_rewrite { shift; # class my ( $event, $results, $groupnum, $kind, $lhs, $rhs, $global ) = @_; my @location; if( $groupnum == -1 ) { @location = ( 0, -1 ); } else { foreach my $groups ( @{ $results->get_result( "matchgroups" ) } ) { my $group = $groups->[$groupnum] or next; @location = @$group; last; # can only do the first one } } ref $event->{text} or $event->{text} = Circle::TaggedString->new( $event->{text} ); my $text = $event->{text}->substr( $location[0], $location[1] ); if( $kind eq "literal" ) { $text = $lhs; } elsif( $kind eq "subst" ) { $text =~ s/$lhs/$rhs/ if !$global; $text =~ s/$lhs/$rhs/g if $global; } $event->{text}->set_substr( $location[0], $location[1], $text ); } ### FORMAT sub parse_action_format : Rule_description("Apply formatting to the line or matched parts") : Rule_format('line|matches|match(number) key="value" [key="value" ...]') { shift; # class my ( $spec ) = @_; $spec =~ s/^(\w+)\s*// or die "Expected type as first argument\n"; my $type = $1; my $groupnum; if( $type eq "line" ) { $groupnum = -1; } elsif( $type eq "matches" ) { $groupnum = 0; } elsif( $type eq "match" ) { $spec =~ s/^\((\d+)\)\s*// or die "Expected match group number\n"; $groupnum = $1; } else { die "Unrecognised format type $type\n"; } my %format; while( $spec =~ s/^(\w+)=// ) { my $name = $1; my $value = extract_delimited( $spec, q{"'} ); s/^["']//, s/["']$// for $value; $format{$name} = $value; $spec =~ s/^\s+//; } if( length $spec ) { die "Unrecognised format spec $spec\n"; } return ( $groupnum, \%format ); } sub deparse_action_format { shift; # class my ( $groupnum, $formathash ) = @_; return unless %$formathash; my $type = $groupnum == -1 ? "line" : $groupnum == 0 ? "matches" : "match($groupnum)"; return "$type ".join( " ", map { qq($_="$formathash->{$_}") } sort keys %$formathash ); } sub eval_action_format { shift; # class my ( $event, $results, $groupnum, $formathash ) = @_; my $str = $event->{text}; ref $str or $str = Circle::TaggedString->new( $str ); if( $groupnum == -1 ) { $str->apply_tag( 0, -1, $_, $formathash->{$_} ) for keys %$formathash; } else { foreach my $groups ( @{ $results->get_result( "matchgroups" ) } ) { my $group = $groups->[$groupnum] or next; my ( $start, $len ) = @$group; $str->apply_tag( $start, $len, $_, $formathash->{$_} ) for keys %$formathash; } } } ### UNFORMAT sub parse_action_unformat : Rule_description("Remove formatting from the line or matched parts") : Rule_format('line|matches|match(number) key [key ...]') { shift; # class my ( $spec ) = @_; $spec =~ s/^(\w+)\s*// or die "Expected type as first argument\n"; my $type = $1; my $groupnum; if( $type eq "line" ) { $groupnum = -1; } elsif( $type eq "matches" ) { $groupnum = 0; } elsif( $type eq "match" ) { $spec =~ s/^\((\d+)\)\s*// or die "Expected match group number\n"; $groupnum = $1; } else { die "Unrecognised format type $type\n"; } my @tags; while( $spec =~ s/^(\w+)// ) { my $name = $1; push @tags, $name; $spec =~ s/^\s+//; } if( length $spec ) { die "Unrecognised format spec $spec\n"; } return ( $groupnum, \@tags ); } sub deparse_action_unformat { shift; # class my ( $groupnum, $taglist ) = @_; my $type = $groupnum == -1 ? "line" : $groupnum == 0 ? "matches" : "match($groupnum)"; my $ret = $type; $ret .= " $_" for @$taglist; return $ret; } my @alltags = qw( fg bg b u i ); sub eval_action_unformat { shift; # class my ( $event, $results, $groupnum, $taglist ) = @_; $taglist = \@alltags unless @$taglist; my $str = $event->{text}; ref $str or $str = Circle::TaggedString->new( $str ); if( $groupnum == -1 ) { $str->unapply_tag( 0, -1, $_ ) for @$taglist; } else { foreach my $groups ( @{ $results->get_result( "matchgroups" ) } ) { my $group = $groups->[$groupnum] or next; my ( $start, $len ) = @$group; $str->unapply_tag( $start, $len, $_ ) for @$taglist; } } } ### LEVEL sub parse_action_level : Rule_description("Set the activity level for the targetted item") : Rule_format('$level') { shift; # class my ( $spec ) = @_; $spec =~ s/^(\d)// or die "Expected level number as first argument\n"; my $level = $1; $level >= 0 and $level <= 3 or die "Expected 'level' between 0 and 3\n"; return ( $level ); } sub deparse_action_level { shift; # class my ( $level ) = @_; return "$level"; } sub eval_action_level { shift; # class my ( $event, $results, $level ) = @_; $event->{level} = $level; } ## HIGHLIGHT sub parse_action_highlight : Rule_description("Highlight matched regions and set activity level to 3") : Rule_format('') { my $self = shift; return; } sub deparse_action_highlight { my $self = shift; return; } sub eval_action_highlight { my $self = shift; my ( $event, $results ) = @_; my $str = $event->{text}; ref $str or $str = Circle::TaggedString->new( $str ); foreach my $matchgroup ( @{ $results->get_result( "matchgroups" ) } ) { my ( $start, $len ) = @{$matchgroup->[0]}[0,1]; $str->apply_tag( $start, $len, b => 1 ); $str->apply_tag( $start, $len, fg => "highlight" ); } $event->{level} = 3; } 0x55AA; circle-be-0.173320/lib/Circle/Loggable.pm000444001750001750 2147613207602007 16524 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2014 -- leonerd@leonerd.org.uk package Circle::Loggable; use strict; use warnings; use base qw( Circle::Commandable Circle::Configurable ); our $VERSION = '0.173320'; use File::Basename qw( dirname ); use File::Path qw( make_path ); use POSIX qw( strftime mktime ); __PACKAGE__->APPLY_Inheritable_Setting( log_enabled => description => "Enable logging of events", type => 'bool', ); __PACKAGE__->APPLY_Inheritable_Setting( log_path => description => "Path template for log file name", type => 'str', ); use Struct::Dumb qw( readonly_struct ); # Data about the log file itself readonly_struct LogId => [qw( path time_start time_until itempath line_timestamp_fmt )]; # Data about logging from a particular item readonly_struct LogCtx => [qw( path_residue )]; our $NO_LOG = 0; sub push_log { my $self = shift; my ( $event, $time, $args ) = @_; return unless $self->setting_log_enabled; return if $NO_LOG; # Best-effort eval { my $logger = $self->logger( $time ); my $ctx = $self->{logctx}; $logger->log( $ctx, $time, $event, $args ); 1; } and return; { local $NO_LOG = 1; warn "Unable to log - $@"; } } my %time_format_to_idx = ( Y => 5, m => 4, d => 3, H => 2, M => 1, S => 0, ); # Returns a LogId and a LogCtx sub split_logpath { my $self = shift; my ( $time ) = @_; my @pcs = split m{/}, $self->enumerable_path; shift @pcs; # trim leading / @pcs or @pcs = ( "Global" ); my $path_used = 0; my %ts_used = map { $_ => 0 } qw( Y m d H M ); my @timestamp = localtime $time; my %formats = ( # Specific kinds of time format so we can track the granulity being used ( map { my $format = $_; $format => sub { $ts_used{$format}++; strftime( "%$format", @timestamp ) }; } qw( Y m d H M ) ), P => sub { my ( $limit ) = @_; defined $limit or $limit = @pcs; my $path_lower = $path_used; my $path_upper = $limit; $path_used = $path_upper if $path_upper > $path_used; return join '/', map { $_ // "" } @pcs[$path_lower..$path_upper-1]; }, ); my $path = $self->setting_log_path; $path =~ s<%(?:{([^}]*)})?(.)> {exists $formats{$2} ? $formats{$2}->($1) : die "Unrecognised escape '%$2"}eg; # Reset to zero all the fields that aren't used $ts_used{$_} or $timestamp[$time_format_to_idx{$_}] = 0 for qw( Y m d H M S ); $timestamp[3] or $timestamp[3] = 1; # mday is 1-based my $time_start = strftime( "%Y/%m/%d %H:%M:%S", @timestamp ); # Increment the last timestamp field before a field not used in the file # path $ts_used{$_} or $timestamp[$time_format_to_idx{$_}+1]++, last for qw( m d H M S ); my $time_until = mktime @timestamp; my $time_fmt_day = join "/", map { $ts_used{$_} ? () : ( "\%$_" ) } qw( Y m d ); my $time_fmt_sec = join ":", map { $ts_used{$_} ? () : ( "\%$_" ) } qw( H M S ); my $logid = LogId( $path, $time_start, $time_until, join( '/', grep { defined } @pcs[0..$path_used-1] ), join( " ", grep { length } $time_fmt_day, $time_fmt_sec ), ); my $logctx = LogCtx( join( '/', grep { defined } @pcs[$path_used..$#pcs] ), ); return ( $logid, $logctx ); } our %LOGGER_FOR_PATH; sub logger { my $self = shift; my ( $time ) = @_; my ( $logid, $logctx ) = $self->split_logpath( $time ); my $path = $logid->path; if( defined $self->{logpath} and $self->{logpath} ne $path ) { $self->close_logger; } if( defined $self->{loguntil} and $time >= $self->{loguntil} ) { $self->close_logger; } my $logger = $LOGGER_FOR_PATH{$path} ||= do { my $dir = dirname( $path ); unless( -d $dir ) { make_path( $dir, { mode => 0700 } ) or die "Cannot mkdir $dir - $!"; } Circle::Loggable::Backend::CircleLog->open( $logid ); }; if( !defined $self->{logpath} ) { $self->{logpath} = $path; $self->{loguntil} = $logid->time_until; $logger->hold_ref; # TODO set up a timer to expire and close the log at that time } $self->{logctx} = $logctx; return $logger; } sub close_logger { my $self = shift; my $logger = $LOGGER_FOR_PATH{$self->{logpath} // ""} or return; $logger->drop_ref; if( !$logger->refcount ) { delete $LOGGER_FOR_PATH{$self->{logpath}}; $logger->close; } undef $self->{logpath}; } sub command_log : Command_description("Configure logging") { } sub command_log_info : Command_description("Show information about logging") : Command_subof('log') : Command_default() { my $self = shift; my ( $cinv ) = @_; if( $self->_setting_log_enabled_inherits ) { $cinv->respond( "Logging is inherited (currently " . ( $self->setting_log_enabled ? "enabled" : "disabled" ) . ")" ); } elsif( $self->setting_log_enabled ) { $cinv->respond( "Logging is directly enabled" ); } else { $cinv->respond( "Logging is directly disabled" ); } if( $self->setting_log_enabled ) { my ( $logid, $logctx ) = $self->split_logpath( time ); $cinv->respond( "Logging to path " . $logid->path ); $cinv->respond( "Timestamp starts " . $logid->time_start ); $cinv->respond( "Timestamp until " . strftime( "%Y/%m/%d %H:%M:%S", localtime $logid->time_until ) ); $cinv->respond( "Line timestamp is " . $logid->line_timestamp_fmt ); $cinv->respond( "Path residue is " . $logctx->path_residue ); } return; } sub command_log_enable : Command_description("Enable logging of this item and its children") : Command_subof('log') { my $self = shift; my ( $cinv ) = @_; $self->setting_log_enabled( 1 ); $cinv->respond( "Logging enabled" ); return; } sub command_log_disable : Command_description("Disable logging of this item and its children") : Command_subof('log') { my $self = shift; my ( $cinv ) = @_; $self->setting_log_enabled( 0 ); $cinv->respond( "Logging disabled" ); return; } sub command_log_inherit : Command_description("Inherit log enabled state from parent") : Command_subof('log') { my $self = shift; my ( $cinv ) = @_; $self->setting_log_enabled( undef ); $cinv->respond( "Logging inherited (currently " . $self->setting_log_enabled ? "enabled" : "disabled" ); return; } sub command_log_rotate : Command_description("Rotate the current log file handle") : Command_subof('log') { my $self = shift; my ( $cinv ) = @_; my $path; my $n_suffix = 1; $n_suffix++ while -f ( $path = "$self->{logpath}.$n_suffix" ); unless( rename( $self->{logpath}, $path ) ) { $cinv->responderr( "Cannot rename $self->{logpath} to $path - $!" ); return; } $cinv->respond( "Log file rotated to $path" ); $self->{logger}->close; undef $self->{logger}; return; } package # hide Circle::Loggable::Backend::CircleLog; use POSIX qw( strftime ); sub open { my $class = shift; my ( $id ) = @_; my $path = $id->path; open my $fh, ">>", $path or die "Cannot open event log $path - $!"; chmod $fh, 0600; $fh->binmode( ":encoding(UTF-8)" ); $fh->autoflush; $fh->print( "!LOG START=\"${\$id->time_start}\" ITEMS=\"${\$id->itempath}\" TIMESTAMP_FMT=\"${\$id->line_timestamp_fmt}\"\n" ); return bless { fh => $fh, refcount => 0, id => $id, }, $class; } sub refcount { shift->{refcount} } sub hold_ref { shift->{refcount}++ } sub drop_ref { shift->{refcount}-- } sub close { my $self = shift; warn "Closing $self with references open" if $self->{refcount}; close $self->{fh}; } sub log { my $self = shift; my ( $ctx, $time, $event, $args ) = @_; my $line = strftime( $self->{id}->line_timestamp_fmt, localtime $time ); $line .= " ".$ctx->path_residue if length $ctx->path_residue; $line .= " $event"; $line .= " ".$self->encode( $args ); $line .= "\n"; $self->{fh}->print( $line ); } ## This should output a valid YAML encoding of a data tree, on a single line # using flow-style mappings and sequences # Similar to JSON except without quoted keys sub encode { my $self = shift; my ( $args ) = @_; if( !ref $args ) { my $str = "$args"; $str =~ s/(["\\])/\\$1/g; $str =~ s/\n/\\n/g; $str =~ s/\t/\\t/g; $str =~ s/([\x00-\x1f\x80-\x9f])/sprintf "\\x%02x", ord $1/eg; return qq("$str"); } elsif( ref $args eq "HASH" ) { return "{" . join( ", ", map { "$_: ".$self->encode( $args->{$_} ) } sort keys %$args ) . "}"; } elsif( ref $args eq "ARRAY" ) { return "[" . join( ", ", map { $self->encode( $args->[$_] ) } 0 .. $#$args ) . "]"; } else { return "$args"; } } 0x55AA; circle-be-0.173320/lib/Circle/Net.pm000444001750001750 202613207602007 15504 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2017 -- leonerd@leonerd.org.uk package Circle::Net; use strict; use warnings; use base qw( Tangence::Object Circle::WindowItem ); our $VERSION = '0.173320'; sub set_network_status { my $self = shift; my ( $status ) = @_; $self->{status} = $status; my $text = $self->get_prop_tag; $text .= "[$self->{status}]" if length $self->{status}; $self->{widget_netname}->set_prop_text( $text ) if $self->{widget_netname}; } sub get_widget_netname { my $self = shift; return $self->{widget_netname} ||= do { my $registry = $self->{registry}; my $widget = $registry->construct( "Circle::Widget::Label", classes => [qw( netname )], ); $self->watch_property( "tag", on_updated => sub { my $text = $_[1]; $text .= "[$self->{status}]" if length $self->{status}; $widget->set_prop_text( $text ); } ); $widget; }; } 0x55AA; circle-be-0.173320/lib/Circle/RootObj.pm000444001750001750 3273513207602007 16366 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk package Circle::RootObj; use strict; use warnings; use base qw( Tangence::Object Circle::WindowItem ); our $VERSION = '0.173320'; use Class::Method::Modifiers; use Carp; use YAML (); # 'Dump' and 'Load' are a bit generic; we'll call by FQN use Circle::Rule::Store; require Circle::GlobalRules; use Circle::CommandInvocation; use Module::Pluggable sub_name => "net_types", search_path => [ "Circle::Net" ], only => qr/^Circle::Net::\w+$/, # Not inner ones force_search_all_paths => 1; { foreach my $class ( net_types ) { ( my $file = "$class.pm" ) =~ s{::}{/}g; require $file; } } use Data::Dump; use constant CIRCLERC => $ENV{CIRCLERC} || "$ENV{HOME}/.circlerc"; sub _nettype2class { my ( $type ) = @_; foreach ( __PACKAGE__->net_types ) { my $thistype = eval { $_->NETTYPE }; if( defined $thistype and $thistype eq $type ) { return $_; } } return undef; } sub new { my $class = shift; my %args = @_; my $loop = delete $args{loop} or croak "Need a loop"; my $self = $class->SUPER::new( %args ); $self->{loop} = $loop; my $rulestore = $self->{rulestore} = Circle::Rule::Store->new(); Circle::GlobalRules::register( $rulestore ); my $file = $args{config} // CIRCLERC; if( -r $file ) { my $config = YAML::LoadFile( $file ); $self->load_configuration( $config ); } return $self; } sub add_network { my $self = shift; my ( $class, $name ) = @_; my $loop = $self->{loop}; # Late-loading to support out-of-tree classes so they don't have to declare # in the .tan file eval { Tangence::Class->for_perlname( $class ) } or eval { $class->DECLARE_TANGENCE } or croak "Unknown Tangence::Class for '$class' and can't lazy-load it"; my $registry = $self->{registry}; my $newnet = $registry->construct( $class, tag => $name, root => $self, loop => $loop, ); $newnet->subscribe_event( destroy => sub { my ( $newnet ) = @_; $self->broadcast_sessions( "delete_item", $newnet ); $self->del_prop_networks( $name ); } ); $self->fire_event( "network_added", $newnet ); $self->add_prop_networks( $name => $newnet ); $self->broadcast_sessions( "new_item", $newnet ); return $newnet; } sub del_network { my $self = shift; my ( $network ) = @_; $network->destroy; } use Circle::Collection name => 'networks', storage => { list => sub { my $self = shift; my $networks = $self->get_prop_networks; return map { { name => $_, type => $networks->{$_}->NETTYPE } } sort keys %$networks; }, get => sub { my $self = shift; my ( $name ) = @_; my $network = $self->get_prop_networks->{$name} or return undef; return { name => $name, type => $network->NETTYPE }; }, add => sub { my $self = shift; my ( $name, $item ) = @_; my $class = _nettype2class( $item->{type} ); defined $class or die "unrecognised network type '$item->{type}'\n"; $self->add_network( $class, $name ); }, del => sub { my $self = shift; my ( $name ) = @_; my $network = $self->get_prop_networks->{$name} or return; $network->connected and die "still connected\n"; $self->del_network( $network ); }, }, attrs => [ name => {}, type => { nomod => 1, default => "irc" }, ], config => { type => "hash", load => sub { my $self = shift; my ( $name, $ynode ) = @_; $self->get_prop_networks->{$name}->load_configuration( $ynode ); }, store => sub { my $self = shift; my ( $name, $ynode ) = @_; $self->get_prop_networks->{$name}->store_configuration( $ynode ); }, }, ; our %sessions; sub add_session { my $self = shift; my ( $identity, $type ) = @_; eval "require $type"; die $@ if $@; my $registry = $self->{registry}; my $session = $registry->construct( $type, root => $self, identity => $identity, ); return $sessions{$identity} = $session; } sub method_get_session { my $self = shift; my ( $ctx, $opts ) = @_; my $identity = $ctx->stream->identity; return $sessions{$identity} if exists $sessions{$identity}; my $type = _session_type( $opts ); defined $type or die "Cannot identify a session type\n"; return $self->add_session( $identity, $type ); } sub broadcast_sessions { my $self = shift; my ( $method, @args ) = @_; foreach my $session ( values %sessions ) { $session->$method( @args ) if $session->can( $method ); } } sub invoke_session { my $self = shift; my ( $conn, $method, @args ) = @_; my $session = $sessions{$conn->identity}; return unless $session; $session->$method( @args ) if $session->can( $method ); } sub _session_type { my ( $opts ) = @_; my %opts = map { $_ => 1 } @$opts; if( $opts{tabs} ) { delete $opts{tabs}; require Circle::Session::Tabbed; return Circle::Session::Tabbed::_session_type( \%opts ); } print STDERR "Need Session for options\n"; print STDERR " ".join( "|", sort keys %opts )."\n"; return undef; } use Circle::Collection name => 'sessions', storage => { list => sub { map { my $class = ref $sessions{$_}; $class =~ s/^Circle::Session:://; { name => $_, type => $class } } sort keys %sessions; }, }, attrs => [ name => {}, type => { nomod => 1 }, ], commands => { # Disable add modify del add => undef, mod => undef, del => undef, }, config => 0, ; sub command_session : Command_description("Manage the current session") { } sub command_session_info : Command_description("Show information about the session") : Command_subof('session') : Command_default() { my $self = shift; my ( $cinv ) = @_; my $identity = $cinv->connection->identity; my $session = defined $identity ? $sessions{$identity} : undef; unless( defined $session ) { $cinv->responderr( "Cannot find a session for this identity" ); return; } ( my $type = ref $session ) =~ s/^Circle::Session:://; $cinv->respond_table( [ [ Type => $type ], [ Identity => $identity ], [ Items => scalar $session->items ], ], colsep => ": ", ); return; } sub command_session_clonefrom : Command_description("Clone items from another session") : Command_subof('session') : Command_arg('name') { my $self = shift; my ( $name, $cinv ) = @_; my $identity = $cinv->connection->identity; my $destsession = defined $identity ? $sessions{$identity} : undef or return $cinv->responderr( "Cannot find a session for this identity" ); my $srcsession = $sessions{$name} or return $cinv->responderr( "Cannot find a session called '$name'" ); eval { $destsession->clonefrom( $srcsession ); 1 } or return $cinv->responderr( "Cannot clone $name into $identity - $@" ); return; } sub command_eval : Command_description("Evaluate a perl expression") : Command_arg('expr', eatall => 1) { my $self = shift; my ( $expr, $cinv ) = @_; my $connection = $cinv->connection; my $identity = $connection->identity; my $session = defined $identity ? $sessions{$identity} : undef; my %pad = ( ROOT => $self, LOOP => $self->{loop}, CONN => $connection, ITEM => $cinv->invocant, SESSION => $session, ); my $result = do { local $SIG{__WARN__} = sub { my $msg = $_[0]; $msg =~ s/ at \(eval \d+\) line \d+\.$//; chomp $msg; $cinv->respondwarn( $msg, level => 2 ); }; eval join( "", map { "my \$$_ = \$pad{$_}; " } keys %pad ) . "$expr"; }; if( $@ ) { my $err = $@; chomp $err; $cinv->responderr( "Died: $err" ); } else { my @lines; my $timedout; local $SIG{ALRM} = sub { $timedout = 1; die }; eval { alarm(5); @lines = split m/\n/, Data::Dump::dump($result); alarm(0); }; if( $timedout ) { $cinv->responderr( "Failed - took too long to render results. Try something more specific" ); return; } if( @lines > 20 ) { @lines = ( @lines[0..18], "...", $lines[-1] ); } if( @lines == 1 ) { $cinv->respond( "Result: $lines[0]" ); } else { $cinv->respond( "Result:" ); $cinv->respond( " $_" ) for @lines; } } return; } sub command_rerequire : Command_description("Rerequire a perl module") : Command_arg('module') { my $self = shift; my ( $module, $cinv ) = @_; # This might be a module name Foo::Bar or a filename Foo/Bar.pm my $filename; if( $module =~ m/::/ ) { ( $filename = $module ) =~ s{::}{/}g; $filename .= ".pm"; } elsif( $module =~ m/^(.*)\.pm$/ ) { $filename = $module; ( $module = $1 ) =~ s{/}{::}g; } else { return $cinv->responderr( "Unable to recognise if $module is a module name or a file name" ); } if( !exists $INC{$filename} ) { return $cinv->responderr( "Module $module in file $filename isn't loaded" ); } { local $SIG{__WARN__} = sub { my $msg = $_[0]; $msg =~ s/ at \(eval \d+\) line \d+\.$//; chomp $msg; $cinv->respondwarn( $msg, level => 2 ); }; no warnings 'redefine'; delete $INC{$filename}; eval { require $filename }; } if( $@ ) { my $err = $@; chomp $err; $cinv->responderr( "Died: $err" ); } else { $cinv->respond( "Reloaded $module from $filename" ); } return; } sub commandable_parent { my $self = shift; my ( $cinv ) = @_; return $sessions{$cinv->connection->identity}; } sub enumerate_items { my $self = shift; my $networks = $self->get_prop_networks; return { map { $_->enumerable_name => $_ } values %$networks }; } sub enumerable_name { return ""; } sub parent { return undef; } sub command_delay : Command_description("Run command after some delay") : Command_arg('seconds') : Command_arg('command', eatall => 1) { my $self = shift; my ( $seconds, $text, $cinv ) = @_; # TODO: A CommandInvocant subclass that somehow prefixes its output so we # know it's delayed output from earlier, so as not to confuse my $subinv = $cinv->nest( $text ); my $cmdname = $subinv->peek_token or return $cinv->responderr( "No command given" ); my $loop = $self->{loop}; my $id = $loop->enqueue_timer( delay => $seconds, code => sub { eval { $subinv->invocant->do_command( $subinv ); }; if( $@ ) { my $err = $@; chomp $err; $cinv->responderr( "Delayed command $cmdname failed - $err" ); } }, ); # TODO: Store ID, allow list, cancel, etc... return; } ### # Configuration management ### sub command_config : Command_description("Save configuration or change details about it") { # The body doesn't matter as it never gets run } sub command_config_show : Command_description("Show the configuration that would be saved") : Command_subof('config') : Command_default() { my $self = shift; my ( $cinv ) = @_; # Since we're only showing config, only fetch it for the invocant my $obj = $cinv->invocant; unless( $obj->can( "get_configuration" ) ) { $cinv->respond( "No configuration" ); return; } my $config = YAML::Dump( $obj->get_configuration ); $cinv->respond( $_ ) for split m/\n/, $config; return; } sub command_config_save : Command_description("Save configuration to disk") : Command_subof('config') { my $self = shift; my ( $cinv ) = @_; my $file = CIRCLERC; YAML::DumpFile( $file, $self->get_configuration ); $cinv->respond( "Configuration written to $file" ); return; } sub command_config_reload : Command_description("Reload configuration from disk") : Command_subof('config') { my $self = shift; my ( $cinv ) = @_; my $file = CIRCLERC; $self->load_configuration( YAML::LoadFile( $file ) ); $cinv->respond( "Configuration loaded from $file" ); return; } # For Configurable role after load_configuration => sub { my $self = shift; my ( $ynode ) = @_; if( my $sessions_ynode = $ynode->{sessions} ) { foreach my $sessionname ( keys %$sessions_ynode ) { my $sessionnode = $sessions_ynode->{$sessionname}; my $type = $sessionnode->{type}; my $session = $self->add_session( $sessionname, "Circle::Session::$type" ); $session->load_configuration( $sessionnode ); } } }; after store_configuration => sub { my $self = shift; my ( $ynode ) = @_; my $sessions_ynode = $ynode->{sessions} ||= YAML::Node->new({}); %$sessions_ynode = (); foreach my $identity ( keys %sessions ) { my $session = $sessions{$identity}; my $sessionnode = $session->get_configuration; $sessions_ynode->{$identity} = $sessionnode; unless( $sessionnode->{type} ) { # exists doesn't quite play ball # Ensure it's first unshift @{ tied(%$sessionnode)->keys }, 'type'; # I am going to hell for this ( $sessionnode->{type} ) = (ref $session) =~ m/^Circle::Session::(.*)$/; } } }; 0x55AA; circle-be-0.173320/lib/Circle/Ruleable.pm000444001750001750 1354213207602007 16536 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk package Circle::Ruleable; use strict; use warnings; use base qw( Circle::Commandable ); our $VERSION = '0.173320'; sub init_rulestore { my $self = shift; my %args = @_; $self->{rulestore} = Circle::Rule::Store->new( %args ); } sub run_rulechain { my $self = shift; my ( $chainname, $event ) = @_; return if eval { $self->{rulestore}->run( $chainname, $event ); 1 }; my $err = $@; chomp $err; $self->responderr( "Exception during processing of rulechain '$chainname': $err" ); } sub command_rules : Command_description("Display or manipulate action rules") { # The body doesn't matter as it never gets run } sub command_rules_list : Command_description("List the action rules") : Command_subof('rules') : Command_default() : Command_arg('chain?') { my $self = shift; my ( $chain, $cinv ) = @_; my $rulestore = $self->{rulestore}; my @chains = $rulestore->chains; if( defined $chain ) { grep { $chain eq $_ } @chains or return $cinv->responderr( "No such rule chain '$chain'" ); } foreach my $chain ( sort @chains ) { $cinv->respond( "Chain '$chain':" ); my @rules = $rulestore->get_chain( $chain )->deparse_rules(); $cinv->respond( "$_: $rules[$_]" ) for 0 .. $#rules; } return; } sub command_rules_add : Command_description("Add a new rule") : Command_subof('rules') : Command_arg('chain') : Command_arg('spec', eatall => 1) { my $self = shift; my ( $chain, $spec, $cinv ) = @_; my $rulestore = $self->{rulestore}; $rulestore->get_chain( $chain )->append_rule( $spec ); $cinv->respond( "Added to chain $chain" ); } sub command_rules_insert : Command_description("Insert a rule before another rule") : Command_subof('rules') : Command_arg('chain') : Command_arg('index') : Command_arg('spec', eatall => 1) { my $self = shift; my ( $chain, $index, $spec, $cinv ) = @_; $index =~ m/^\d+$/ or return $cinv->responderr( "Bad index: $index" ); my $rulestore = $self->{rulestore}; $rulestore->get_chain( $chain )->insert_rule( $index, $spec ); $cinv->respond( "Inserted in $chain before rule $index" ); } sub command_rules_replace : Command_description("Replace an existing rule with a new one") : Command_subof('rules') : Command_arg('chain') : Command_arg('index') : Command_arg('spec', eatall => 1) { my $self = shift; my ( $chain, $index, $spec, $cinv ) = @_; # We'll do this by inserting our new rule before the one we want to # replace. If it works, delete the old one, which will now be one further # down. my $rulestore = $self->{rulestore}; my $rulechain = $rulestore->get_chain( $chain ); $rulechain->insert_rule( $index, $spec ); $rulechain->delete_rule( $index + 1 ); $cinv->respond( "Replaced $chain rule $index" ); } sub command_rules_delete : Command_description("Delete a rule") : Command_subof('rules') : Command_arg('chain') : Command_arg('index') { my $self = shift; my ( $chain, $index, $cinv ) = @_; $index =~ m/^\d+$/ or return $cinv->responderr( "Bad index: $index" ); my $rulestore = $self->{rulestore}; $rulestore->get_chain( $chain )->delete_rule( $index ); $cinv->respond( "Deleted $chain rule $index" ); } sub command_rules_describe : Command_description("Describe rule conditions or actions") : Command_subof('rules') : Command_arg('name?') : Command_opt('conds=+', desc => "List conditions") : Command_opt('actions=+', desc => "List actions") { my $self = shift; my ( $name, $opts, $cinv ) = @_; my $rulestore = $self->{rulestore}; my @names; if( defined $name ) { @names = ( $name ); } else { # List both if neither or both options specified push @names, sort $rulestore->list_conds if !$opts->{actions} or $opts->{conds}; push @names, sort $rulestore->list_actions if !$opts->{conds} or $opts->{actions}; } for my $name ( @names ) { if( my $attrs = eval { $rulestore->describe_cond( $name ) } ) { my $description = $attrs->{desc} || "[has no description]"; $cinv->respond( "Condition '$name': $description" ); $cinv->respond( " $name($attrs->{format})" ) if defined $attrs->{format}; } elsif( $attrs = eval { $rulestore->describe_action( $name ) } ) { my $description = $attrs->{desc} || "[has no description]"; $cinv->respond( "Action '$name': $description" ); $cinv->respond( " $name($attrs->{format})" ) if defined $attrs->{format}; } else { $cinv->responderr( "No such condition or action '$name'" ); } } return; } use Class::Method::Modifiers qw( install_modifier ); sub APPLY_Ruleable { my $caller = caller; install_modifier $caller, after => load_configuration => sub { my $self = shift; my ( $ynode ) = @_; return unless my $rules_ynode = $ynode->{rules}; my $rulestore = $self->{rulestore}; foreach my $chain ( keys %$rules_ynode ) { my $chain_ynode = $rules_ynode->{$chain}; my $chain = $rulestore->new_chain( $chain ); # or fetch the existing one $chain->clear; $chain->append_rule( $_ ) for @$chain_ynode; } }; install_modifier $caller, after => store_configuration => sub { my $self = shift; my ( $ynode ) = @_; my $rulestore = $self->{rulestore}; my $rules_ynode = $ynode->{rules} ||= YAML::Node->new({}); foreach my $chain ( $rulestore->chains ) { my $chain_ynode = $rules_ynode->{$chain} = [ $rulestore->get_chain( $chain )->deparse_rules(), ]; } # Delete any of the old ones $rulestore->get_chain( $_ ) or delete $rules_ynode->{$_} for keys %$rules_ynode; }; } 0x55AA; circle-be-0.173320/lib/Circle/TaggedString.pm000444001750001750 171313207602007 17342 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2010 -- leonerd@leonerd.org.uk package Circle::TaggedString; use strict; use warnings; use base qw( String::Tagged ); String::Tagged->VERSION( '0.11' ); our $VERSION = '0.173320'; sub new_from_formatting { my $class = shift; my ( $orig ) = @_; return $class->clone( $orig, only_tags => [qw( bold under italic reverse monospace blockquote )], convert_tags => { bold => "b", under => "u", italic => "i", reverse => "rv", monospace => "m", blockquote => "bq", # TODO: fg/bg }, ); } sub squash { my $self = shift; my @output; $self->iter_substr_nooverlap( sub { my ( $str, %format ) = @_; push @output, %format ? [ $str, %format ] : $str; } ); return $output[0] if @output == 1 and !ref $output[0]; return \@output; } 0x55AA; circle-be-0.173320/lib/Circle/Widget.pm000444001750001750 74113207602007 16163 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2010 -- leonerd@leonerd.org.uk package Circle::Widget; use strict; use warnings; use base qw( Tangence::Object ); our $VERSION = '0.173320'; sub new { my $class = shift; my %args = @_; my $self = $class->SUPER::new( @_ ); $self->set_prop_classes( $args{classes} ) if $args{classes}; $self->set_prop_focussed( 1 ) if $args{focussed}; return $self; } 0x55AA; circle-be-0.173320/lib/Circle/WindowItem.pm000444001750001750 1274613207602007 17076 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk package Circle::WindowItem; # An abstract role used by objects that should be placed in FE windows or tabs # Combines the behaviours of: # having display events # responding to typed lines of text use strict; use warnings; use base qw( Circle::Commandable Circle::Configurable Circle::Loggable ); use Carp; our $VERSION = '0.173320'; use Circle::TaggedString; use Circle::Widget::Box; use Circle::Widget::Scroller; sub init_prop_level { return 0; } sub bump_level { my $self = shift; my ( $newlevel ) = @_; return if $self->get_prop_level >= $newlevel; $self->set_prop_level( $newlevel ); } sub method_reset_level { my $self = shift; $self->set_prop_level( 0 ); } sub push_displayevent { my $self = shift; my ( $event, $args, %opts ) = @_; foreach ( values %$args ) { if( !ref $_ ) { next; } elsif( eval { $_->isa( "Circle::TaggedString" ) } ) { $_ = $_->squash; } else { $_ = "[[TODO: Not sure how to handle $_]]"; } } my $time = $opts{time} // time(); my $scroller = $self->get_widget_scroller; $scroller->push_event( $event, $time, $args ); $self->push_log( $event, $time, $args ); } sub respond { my $self = shift; my ( $text, %opts ) = @_; $self->push_displayevent( "response", { text => $text } ); $self->bump_level( $opts{level} ) if $opts{level}; return; } sub respondwarn { my $self = shift; my ( $text, %opts ) = @_; $self->push_displayevent( "warning", { text => $text } ); $self->bump_level( $opts{level} ) if $opts{level}; return; } sub responderr { my $self = shift; my ( $text, %opts ) = @_; $self->push_displayevent( "error", { text => $text } ); $self->bump_level( $opts{level} ) if $opts{level}; return; } sub respond_table { my $self = shift; my ( $tableref, %opts ) = @_; # We need to avoid using join() or sprintf() here, because any of the table # cell arguments might be TaggedString objects. The CORE functions won't # respect this taggnig. my $colsep = exists $opts{colsep} ? delete $opts{colsep} : " "; my $headings = delete $opts{headings}; my @table = @$tableref; my @width; foreach my $r ( $headings, @table ) { next unless defined $r; foreach my $c ( 0 .. $#$r ) { my $d = $r->[$c]; $width[$c] = length $d if !defined $width[$c] or length $d > $width[$c]; } } if( $headings ) { my $text = Circle::TaggedString->new(); foreach my $c ( 0 .. $#$headings ) { $text->append( $colsep ) if $c > 0; my $col = $headings->[$c]; $text->append_tagged( $col . ( " " x ( $width[$c] - length $col ) ), u => 1 ); } $self->respond( $text, %opts ); } foreach my $tr ( @table ) { my $text = Circle::TaggedString->new(); foreach my $c ( 0 .. $#width ) { $text->append( $colsep ) if $c > 0; my $col = $tr->[$c]; $text->append( $col . ( " " x ( $width[$c] - length $col ) ) ); } $self->respond( $text, %opts ); } } sub command_clear : Command_description("Clear the scrollback buffer") : Command_opt('keeplines=$', desc => "keep this number of lines") { my $self = shift; my ( $opts, $cinv ) = @_; my $keeplines = $opts->{keeplines} || 0; my $scroller = $self->get_widget_scroller; my $to_delete = scalar @{ $scroller->get_prop_displayevents } - $keeplines; $scroller->shift_prop_displayevents( $to_delete ) if $to_delete > 0; return; } sub command_dumpevents : Command_description("Dump a log of the raw event buffer") : Command_arg('filename') { my $self = shift; my ( $filename, $cinv ) = @_; my $scroller = $self->get_widget_scroller; YAML::DumpFile( $filename, $scroller->get_prop_displayevents ); $cinv->respond( "Dumped event log to $filename" ); return; } ### # Widget ### sub method_get_widget { my $self = shift; return $self->{widget} ||= $self->make_widget(); } # Useful for debugging and live-development sub command_rewidget : Command_description("Destroy the cached widget tree so it will be recreated") { my $self = shift; delete $self->{widget}; $self->respond( "Destroyed existing widget tree. You will have to restart the frontend now" ); return; } # Subclasses might override this, but we'll provide a default sub make_widget { my $self = shift; my $registry = $self->{registry}; my $box = $registry->construct( "Circle::Widget::Box", orientation => "vertical", ); $self->make_widget_pre_scroller( $box ) if $self->can( "make_widget_pre_scroller" ); $box->add( $self->get_widget_scroller, expand => 1 ); $box->add( $self->get_widget_statusbar ) if $self->can( "get_widget_statusbar" ); $box->add( $self->get_widget_commandentry ); return $box; } sub get_widget_scroller { my $self = shift; return $self->{widget_displayevents} if defined $self->{widget_displayevents}; my $registry = $self->{registry}; my $widget = $registry->construct( "Circle::Widget::Scroller", scrollback => 1000, # TODO ); return $self->{widget_displayevents} = $widget; } sub enumerable_path { my $self = shift; if( my $parent = $self->parent ) { return $parent->enumerable_path . "/" . $self->enumerable_name; } else { return $self->enumerable_name; } } 0x55AA; circle-be-0.173320/lib/Circle/Net000755001750001750 013207602007 15011 5ustar00leoleo000000000000circle-be-0.173320/lib/Circle/Net/IRC.pm000444001750001750 10246113207602007 16165 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2017 -- leonerd@leonerd.org.uk package Circle::Net::IRC; use strict; use warnings; use base qw( Circle::Net Circle::Ruleable ); __PACKAGE__->APPLY_Ruleable; use base qw( Circle::Rule::Store ); # for the attributes our $VERSION = '0.173320'; use constant NETTYPE => 'irc'; use Circle::Net::IRC::Channel; use Circle::Net::IRC::User; use Circle::TaggedString; use Circle::Rule::Store; use Circle::Widget::Box; use Circle::Widget::Label; use Net::Async::IRC 0.10; # on_irc_error use IO::Async::Timer::Countdown; use Text::Balanced qw( extract_delimited ); use Scalar::Util qw( weaken ); sub new { my $class = shift; my %args = @_; my $self = $class->SUPER::new( %args ); $self->{root} = $args{root}; my $loop = $self->{loop} = $args{loop}; # For WindowItem $self->set_prop_tag( $args{tag} ); my $irc = $self->{irc} = Net::Async::IRC->new( # TODO: All these event handler subs should be weaselled on_message => sub { my ( $irc, $command, $message, $hints ) = @_; $self->on_message( $command, $message, $hints ); }, on_closed => sub { $self->on_closed; }, on_irc_error => sub { my ( $irc, $message ) = @_; $self->push_displayevent( "status", { text => "IRC error $message" } ); $self->close_now; }, encoding => "UTF-8", pingtime => 120, on_ping_timeout => sub { $self->on_ping_timeout; }, pongtime => 60, on_pong_reply => sub { my ( $irc, $lag ) = @_; $self->on_ping_reply( $lag ); }, ); weaken( my $weakself = $self ); $self->{reconnect_timer} = IO::Async::Timer::Countdown->new( delay => 1, # Doesn't matter, as ->enqueue_reconnect will set it before start anyway on_expire => sub { $weakself and $weakself->reconnect }, ); $loop->add( $self->{reconnect_timer} ); $self->{servers} = []; $self->{channels} = {}; $self->{users} = {}; my $rulestore = $self->init_rulestore( parent => $args{root}->{rulestore} ); $rulestore->register_cond( matchnick => $self ); $rulestore->register_cond( fromnick => $self ); $rulestore->register_cond( channel => $self ); $rulestore->register_cond( isaction => $self ); $rulestore->register_action( display => $self ); $rulestore->register_action( chaction => $self ); $rulestore->new_chain( "input" ); $rulestore->get_chain( "input" )->append_rule( "matchnick: highlight" ); $rulestore->new_chain( "output" ); $self->set_network_status( "disconnected" ); return $self; } sub describe { my $self = shift; return __PACKAGE__."[". $self->get_prop_tag . "]"; } sub get_prop_users { my $self = shift; my $users = $self->{users}; return [ values %$users ]; } sub reify { # always real; this is a no-op } sub get_channel_if_exists { my $self = shift; my ( $channame ) = @_; my $irc = $self->{irc}; my $channame_folded = $irc->casefold_name( $channame ); return $self->{channels}->{$channame_folded}; } sub get_channel_or_create { my $self = shift; my ( $channame ) = @_; my $irc = $self->{irc}; my $channame_folded = $irc->casefold_name( $channame ); return $self->{channels}->{$channame_folded} if exists $self->{channels}->{$channame_folded}; my $registry = $self->{registry}; my $chanobj = $registry->construct( "Circle::Net::IRC::Channel", root => $self->{root}, net => $self, irc => $irc, name => $channame, ); my $root = $self->{root}; $self->{channels}->{$channame_folded} = $chanobj; $chanobj->subscribe_event( destroy => sub { my ( $chanobj ) = @_; $root->broadcast_sessions( "delete_item", $chanobj ); $self->del_prop_channels( $chanobj ); delete $self->{channels}->{$channame_folded}; } ); $self->add_prop_channels( $chanobj ); return $chanobj; } sub get_user_if_exists { my $self = shift; my ( $nick ) = @_; my $irc = $self->{irc}; my $nick_folded = $irc->casefold_name( $nick ); return $self->{users}->{$nick_folded}; } sub get_user_or_create { my $self = shift; my ( $nick ) = @_; unless( defined $nick and length $nick ) { warn "Unable to create a new user with an empty nick\n"; return undef; } my $irc = $self->{irc}; my $nick_folded = $irc->casefold_name( $nick ); return $self->{users}->{$nick_folded} if exists $self->{users}->{$nick_folded}; my $registry = $self->{registry}; my $userobj = $registry->construct( "Circle::Net::IRC::User", root => $self->{root}, net => $self, irc => $irc, name => $nick, ); my $root = $self->{root}; $self->{users}->{$nick_folded} = $userobj; $userobj->subscribe_event( destroy => sub { my ( $userobj ) = @_; $root->broadcast_sessions( "delete_item", $userobj ); $self->del_prop_users( $userobj ); my $nick_folded = $irc->casefold_name( $userobj->get_prop_name ); delete $self->{users}->{$nick_folded}; } ); $userobj->subscribe_event( change_nick => sub { my ( undef, $oldnick, $oldnick_folded, $newnick, $newnick_folded ) = @_; $self->{users}->{$newnick_folded} = delete $self->{users}->{$oldnick_folded}; } ); $self->add_prop_users( $userobj ); return $userobj; } sub get_target_if_exists { my $self = shift; my ( $name ) = @_; my $irc = $self->{irc}; my $type = $irc->classify_name( $name ); if( $type eq "channel" ) { return $self->get_channel_if_exists( $name ); } elsif( $type eq "user" ) { return $self->get_user_if_exists( $name ); } else { return undef; } } sub get_target_or_create { my $self = shift; my ( $name ) = @_; my $irc = $self->{irc}; my $type = $irc->classify_name( $name ); if( $type eq "channel" ) { return $self->get_channel_or_create( $name ); } elsif( $type eq "user" ) { return $self->get_user_or_create( $name ); } else { return undef; } } sub connect { my $self = shift; my %args = @_; my $irc = $self->{irc}; my $host = $args{host}; my $nick = $args{nick} || $self->get_prop_nick || $self->{configured_nick}; if( $args{SSL} and not eval { require IO::Async::SSL } ) { return Future->new->fail( "SSL is set but IO::Async::SSL is not available" ); } $self->{loop}->add( $irc ) if !$irc->loop; my $f = $irc->login( host => $host, service => $args{port}, nick => $nick, user => $args{ident}, pass => $args{pass}, ( $args{SSL} ? ( extensions => [qw( SSL )], SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE(), ) : () ), local_host => $args{local_host} || $self->{local_host}, on_login => sub { foreach my $target ( values %{ $self->{channels} }, values %{ $self->{users} } ) { $target->on_connected; } $self->set_prop_nick( $nick ); $self->set_network_status( "" ); $self->fire_event( "connected" ); }, on_error => $args{on_error}, ); $self->set_network_status( "connecting" ); $f->on_fail( sub { $self->set_network_status( "disconnected" ) } ); return $f; } sub connected { my $self = shift; # Consider we're "connected" if the underlying IRC object is logged in my $irc = $self->{irc}; return $irc->is_loggedin; } # Map mIRC's colours onto an approximation of ANSI terminal my @irc_colour_map = ( 15, 0, 4, 2, # white black blue green 9, 1, 5, 3, # red [brown=darkred] [purple=darkmagenta] [orange=darkyellow] 11, 10, 6, 14, # yellow lightgreen cyan lightcyan 12, 13, 8, 7 # lightblue [pink=magenta] grey lightgrey ); sub format_colour { my $self = shift; my ( $colcode ) = @_; return $colcode if $colcode =~ m/^#[0-9a-f]{6}/i; return "#$1$1$2$2$3$3" if $colcode =~ m/^#([0-9a-f])([0-9a-f])([0-9a-f])/i; return sprintf( "ansi.col%02d", $irc_colour_map[$1] ) if $colcode =~ m/^(\d\d?)/ and defined $irc_colour_map[$1]; return undef; } sub format_text_tagged { my $self = shift; my ( $text ) = @_; # IRC [well, technically mIRC but other clients have adopted it] uses Ctrl # characters to toggle formatting # ^B = bold # ^U = underline # ^_ = underline # ^R = reverse or italic - we'll use italic # ^V = reverse # ^] = italics # ^O = reset # ^C = colour; followed by a code # ^C = reset colours # ^Cff = foreground # ^Cff,bb = background # # irssi uses the following # ^D$$ = foreground/background, in chr('0'+$colour), # ^Db = underline # ^Dc = bold # ^Dd = reverse or italic - we'll use italic # ^Dg = reset colours # # As a side effect we'll also strip all the other Ctrl chars # We'll also look for "poor-man's" highlighting # *bold* # _underline_ # /italic/ my $ret = Circle::TaggedString->new(); my %format; while( length $text ) { if( $text =~ s/^([\x00-\x1f])// ) { my $ctrl = chr(ord($1)+0x40); if( $ctrl eq "B" ) { $format{b} ? delete $format{b} : ( $format{b} = 1 ); } elsif( $ctrl eq "U" or $ctrl eq "_" ) { $format{u} ? delete $format{u} : ( $format{u} = 1 ); } elsif( $ctrl eq "R" or $ctrl eq "]" ) { $format{i} ? delete $format{i} : ( $format{i} = 1 ); } elsif( $ctrl eq "V" ) { $format{rv} ? delete $format{rv} : ( $format{rv} = 1 ); } elsif( $ctrl eq "O" ) { undef %format; } elsif( $ctrl eq "C" ) { my $colourre = qr/#[0-9a-f]{6}|#[0-9a-f]{3}|\d\d?/i; if( $text =~ s/^($colourre),($colourre)// ) { $format{fg} = $self->format_colour( $1 ) if $self->{use_mirc_colours}; $format{bg} = $self->format_colour( $2 ) if $self->{use_mirc_colours}; } elsif( $text =~ s/^($colourre)// ) { $format{fg} = $self->format_colour( $1 ) if $self->{use_mirc_colours}; } else { delete $format{fg}; delete $format{bg}; } } elsif( $ctrl eq "D" ) { if( $text =~ s/^b// ) { # underline $format{u} ? delete $format{u} : ( $format{u} = 1 ); } elsif( $text =~ s/^c// ) { # bold $format{b} ? delete $format{b} : ( $format{b} = 1 ); } elsif( $text =~ s/^d// ) { # revserse/italic $format{i} ? delete $format{i} : ( $format{i} = 1 ); } elsif( $text =~ s/^g// ) { undef %format } else { $text =~ s/^(.)(.)//; my ( $fg, $bg ) = map { ord( $_ ) - ord('0') } ( $1, $2 ); if( $fg > 0 ) { $format{fg} = sprintf( "ansi.col%02d", $fg ); } if( $bg > 0 ) { $format{bg} = sprintf( "ansi.col%02d", $bg ); } } } else { print STDERR "Unhandled Ctrl code ^$ctrl\n"; } } else { $text =~ s/^([^\x00-\x1f]+)//; my $piece = $1; # Now scan this piece for the text-based ones while( length $piece ) { # Look behind/ahead asserts to ensure we don't capture e.g. # /usr/bin/perl by mistake if( $piece =~ s/^(.*?)(?append_tagged( $pre, %format ) if length $pre; my %innerformat = %format; $type =~ tr{*_/}{bui}; $innerformat{$type} = 1; $ret->append_tagged( $inner, %innerformat ); } else { $ret->append_tagged( $piece, %format ); $piece = ""; } } } } return $ret; } sub format_text { my $self = shift; my ( $text ) = @_; return $self->format_text_tagged( $text ); } ### # Rule subs ### sub parse_cond_matchnick : Rule_description("Look for my IRC nick in the text") : Rule_format('') { my $self = shift; return; } sub deparse_cond_matchnick { my $self = shift; return; } sub eval_cond_matchnick { my $self = shift; my ( $event, $results ) = @_; my $text = $event->{text}->str; my $nick = $self->{irc}->nick; pos( $text ) = 0; my $matched; while( $text =~ m/(\Q$nick\E)/gi ) { my ( $start, $end ) = ( $-[0], $+[0] ); my $len = $end - $start; $results->push_result( "matchgroups", [ [ $start, $len ] ] ); $matched = 1; } return $matched; } sub parse_cond_fromnick : Rule_description("Match the message originating nick against a regexp or string") : Rule_format('/regexp/ or "literal"') { my $self = shift; my ( $spec ) = @_; if( $spec =~ m/^"/ ) { # Literal my $nick = extract_delimited( $spec, q{"} ); s/^"//, s/"$// for $nick; return literal => $nick; } elsif( $spec =~ m{^/} ) { # Regexp my $re = extract_delimited( $spec, q{/} ); s{^/}{}, s{/$}{} for $re; my $iflag = 1 if $spec =~ s/^i//; return re => qr/$re/i if $iflag; return re => qr/$re/; } } sub deparse_cond_fromnick { my $self = shift; my ( $type, $pattern ) = @_; if( $type eq "literal" ) { return qq{"$pattern"}; } elsif( $type eq "re" ) { # Perl tries to put (?-ixsm:RE) around our pattern. Lets attempt to remove # it if we can return "/$1/" if $pattern =~ m/^\(\?-xism:(.*)\)$/; return "/$1/i" if $pattern =~ m/^\(\?i-xsm:(.*)\)$/; # Failed. Lets just be safe then return "/$pattern/"; } } sub eval_cond_fromnick { my $self = shift; my ( $event, $results, $type, $pattern ) = @_; my $src = $event->{prefix_name_folded}; if( $type eq "literal" ) { my $irc = $self->{irc}; return $src eq $irc->casefold_name( $pattern ); } elsif( $type eq "re" ) { return $src =~ $pattern; } } sub parse_cond_channel : Rule_description("Event comes from a (named) channel") : Rule_format('"name"?') { my $self = shift; my ( $spec ) = @_; if( defined $spec and $spec =~ m/^"/ ) { my $name = extract_delimited( $spec, q{"} ); s/^"//, s/"$// for $name; return $name; } return undef; } sub deparse_cond_channel { my $self = shift; my ( $name ) = @_; return qq{"$name"} if defined $name; return; } sub eval_cond_channel { my $self = shift; my ( $event, $results, $name ) = @_; return 0 unless ( $event->{target_type} || "" ) eq "channel"; return 1 unless defined $name; my $irc = $self->{irc}; return $event->{target_name_folded} eq $irc->casefold_name( $name ); } sub parse_cond_isaction : Rule_description("Event is a CTCP ACTION") : Rule_format('') { my $self = shift; return undef; } sub deparse_cond_isaction { my $self = shift; return; } sub eval_cond_isaction { my $self = shift; my ( $event, $results, $name ) = @_; return $event->{is_action}; } sub parse_action_display : Rule_description("Set the display window to display an event") : Rule_format('self|server') { my $self = shift; my ( $spec ) = @_; if( $spec eq "self" ) { return "self"; } elsif( $spec eq "server" ) { return "server"; } else { die "Unrecognised display spec\n"; } } sub deparse_action_display { my $self = shift; my ( $display ) = @_; return $display; } sub eval_action_display { my $self = shift; my ( $event, $results, $display ) = @_; $event->{display} = $display; } sub parse_action_chaction : Rule_description("Change an event to or from being a CTCP ACTION") : Rule_format('0|1') { my $self = shift; my ( $spec ) = @_; return !!$spec; } sub deparse_action_chaction { my $self = shift; my ( $action ) = @_; return $action; } sub eval_action_chaction { my $self = shift; my ( $event, $results, $action ) = @_; $event->{is_action} = $action; } ### # IRC message handlers ### sub on_message { my $self = shift; my ( $command, $message, $hints ) = @_; if( defined $hints->{target_name} ) { my $target; if( $hints->{target_type} eq "channel" ) { $target = $self->get_channel_or_create( $hints->{target_name} ); } elsif( $hints->{target_is_me} and defined $hints->{prefix_name} and not $hints->{prefix_is_me} ) { # Handle PRIVMSG and similar from the user $target = $self->get_user_or_create( $hints->{prefix_name} ); } elsif( $hints->{target_type} eq "user" ) { # Handle numerics about the user - Net::Async::IRC has filled in the target $target = $self->get_user_or_create( $hints->{target_name} ); } if( $target ) { return 1 if $target->on_message( $command, $message, $hints ); } } elsif( grep { $command eq $_ } qw( NICK QUIT ) ) { # Target all of them my $handled = 0; my $method = "on_message_$command"; $handled = 1 if $self->can( $method ) and $self->$method( $message, $hints ); foreach my $target ( values %{ $self->{channels} } ) { $handled = 1 if $target->$method( $message, $hints ); } my $nick_folded = $hints->{prefix_nick_folded}; if( my $userobj = $self->get_user_if_exists( $hints->{prefix_nick} ) ) { $handled = 1 if $userobj->$method( $message, $hints ); } return 1 if $handled; } elsif( $self->can( "on_message_$command" ) ) { my $method = "on_message_$command"; my $handled = $self->$method( $message, $hints ); return 1 if $handled; } if( not $hints->{handled} and not $hints->{synthesized} ) { $self->push_displayevent( "irc.irc", { command => $command, prefix => $message->prefix, args => join( " ", map { "'$_'" } $message->args ), } ); $self->bump_level( 1 ); } } sub on_message_NICK { my $self = shift; my ( $message, $hints ) = @_; if( $hints->{prefix_is_me} ) { $self->set_prop_nick( $hints->{new_nick} ); } return 1; } sub on_message_motd { my $self = shift; my ( $message, $hints ) = @_; my $motd = $hints->{motd}; $self->push_displayevent( "irc.motd", { text => $self->format_text($_) } ) for @$motd; $self->bump_level( 1 ); return 1; } sub on_message_RPL_UNAWAY { my $self = shift; my ( $message, $hints ) = @_; $self->set_prop_away( 0 ); $self->push_displayevent( "irc.text", { server => $hints->{prefix_host}, text => $hints->{text} } ); $self->bump_level( 1 ); return 1; } sub on_message_RPL_NOWAWAY { my $self = shift; my ( $message, $hints ) = @_; $self->set_prop_away( 1 ); $self->push_displayevent( "irc.text", { server => $hints->{prefix_host}, text => $hints->{text} } ); $self->bump_level( 1 ); return 1; } sub on_message_whois { my $self = shift; my ( $message, $hints ) = @_; my $f = delete $self->{whois_gate_f}{$hints->{target_name_folded}} or return 1; $f->done( $hints->{whois} ); } sub on_closed { my $self = shift; my ( $message ) = @_; $message ||= "Server is disconnected"; $self->set_network_status( "disconnected" ); $self->push_displayevent( "status", { text => $message } ); foreach my $target ( values %{ $self->{channels} }, values %{ $self->{users} } ) { $target->on_disconnected( $message ); } $self->fire_event( "disconnected" ); unless( $self->{no_reconnect_on_close} ) { $self->{reconnect_delay_idx} = 0; $self->{reconnect_host_idx} = 0; $self->enqueue_reconnect if !$self->{reconnect_timer}->is_running; } undef $self->{no_reconnect_on_close}; } my @reconnect_delays = ( 5, 5, 10, 30, 60 ); sub enqueue_reconnect { my $self = shift; my $delay = $reconnect_delays[ $self->{reconnect_delay_idx}++ ] // $reconnect_delays[-1]; my $timer = $self->{reconnect_timer}; $timer->configure( delay => $delay ); $timer->start; $self->set_network_status( "reconnect pending..." ); } sub reconnect { my $self = shift; my $s = $self->{servers}->[ $self->{reconnect_host_idx}++ ]; $self->{reconnect_host_idx} %= @{ $self->{servers} }; my $f = $self->connect( host => $s->{host}, port => $s->{port}, user => $s->{user}, pass => $s->{pass}, SSL => $s->{SSL}, ); $f->on_fail( sub { $self->enqueue_reconnect } ); } sub on_ping_timeout { my $self = shift; $self->on_closed( "Ping timeout" ); $self->{irc}->close; } sub on_ping_reply { my $self = shift; my ( $lag ) = @_; if( $lag > 1 ) { $self->set_network_status( sprintf "lag:%.2f", $lag ); } else { $self->set_network_status( "" ); } } sub method_get_isupport { my $self = shift; my ( $ctx, $key ) = @_; my $irc = $self->{irc}; return $irc->isupport( $key ); } sub do_join { my $self = shift; my ( $channel, $key ) = @_; my $pending = $self->{pending_joins} //= []; if( !@$pending ) { my $irc = $self->{irc}; $self->{loop}->later( sub { my $channels = join ",", map { $_->[0] } @$pending; my $keys = join ",", map { defined $_->[1] ? ( $_->[1] ) : () } @$pending; $irc->send_message( "JOIN", undef, $channels, length $keys ? ( $keys ) : () ); @$pending = (); }); } # Enqueue keyed joins first, others last if( defined $key ) { unshift @$pending, [ $channel, $key ]; } else { push @$pending, [ $channel ]; } } use Circle::Collection name => 'servers', storage => 'array', attrs => [ host => { desc => "hostname" }, port => { desc => "alternative port", show => sub { $_ || "6667" }, }, SSL => { desc => "use SSL", show => sub { $_ ? "SSL" : "" }, }, ident => { desc => "alternative ident", show => sub { $_ || '$USER' }, }, pass => { desc => "connection password", show => sub { $_ ? "set" : "" }, }, ], ; sub command_nick : Command_description("Change nick") : Command_arg('nick?') { my $self = shift; my ( $newnick ) = @_; my $irc = $self->{irc}; if( defined $newnick ) { $irc->change_nick( $newnick ); $self->set_prop_nick( $newnick ); } return; } sub command_connect : Command_description("Connect to an IRC server") : Command_arg('host?') : Command_opt('port=$', desc => "alternative port (default '6667')") : Command_opt('SSL=+', desc => "use SSL") : Command_opt('nick=$', desc => "initial nick") : Command_opt('ident=$', desc => "alternative ident (default '\$USER')") : Command_opt('pass=$', desc => "connection password") : Command_opt('local_host=$', desc => "local host to bind") { my $self = shift; my ( $host, $opts, $cinv ) = @_; my $s; if( !defined $host ) { if( !@{ $self->{servers} } ) { $cinv->responderr( "Cannot connect - no servers defined" ); return; } # TODO: Pick one - for now just the first $s = $self->{servers}->[0]; $host = $s->{host}; } else { ( $s ) = grep { $_->{host} eq $host } @{ $self->{servers} }; $s or return $cinv->responderr( "No definition for $host" ); } $self->{reconnect_timer}->stop; my $f = $self->connect( host => $host, nick => $opts->{nick}, port => $opts->{port} || $s->{port}, SSL => $opts->{SSL} || $s->{SSL}, ident => $opts->{ident} || $s->{ident}, pass => $opts->{pass} || $s->{pass}, local_host => $opts->{local_host}, on_error => sub { warn "Empty closure" }, ); $f->on_done( sub { $cinv->respond( "Connected to $host", level => 1 ) } ); $f->on_fail( sub { $cinv->responderr( "Unable to connect to $host - $_[0]", level => 3 ) } ); return ( "Connecting to $host ..." ); } sub command_reconnect : Command_description("Disconnect then reconnect to the IRC server") : Command_arg('message', eatall => 1) { my $self = shift; my ( $message ) = @_; my $irc = $self->{irc}; $irc->send_message( "QUIT", undef, $message ); $irc->close; $self->{no_reconnect_on_close} = 1; $self->reconnect ->on_done( sub { undef $self->{no_reconnect_on_close} }); return; } sub command_disconnect : Command_description("Disconnect from the IRC server") : Command_arg('message?', eatall => 1) { my $self = shift; my ( $message ) = @_; my $irc = $self->{irc}; if( $irc->read_handle ) { $irc->send_message( "QUIT", undef, defined $message ? ( $message ) : () ); $irc->close; $self->{no_reconnect_on_close} = 1; } else { my $timer = $self->{reconnect_timer}; $timer->stop if $timer->is_running; $self->set_network_status( "disconnected" ); } return; } sub command_join : Command_description("Join a channel") : Command_arg('channel') : Command_opt('key=$', desc => "join key") { my $self = shift; my ( $channel, $opts, $cinv ) = @_; my $irc = $self->{irc}; my $chanobj = $self->get_channel_or_create( $channel ); $chanobj->reify; $chanobj->join( key => $opts->{key}, on_joined => sub { $cinv->respond( "Joined $channel", level => 1 ); }, on_join_error => sub { $cinv->responderr( "Cannot join $channel - $_[0]", level => 3 ); }, ); return; } sub command_part : Command_description("Part a channel") : Command_arg('channel') : Command_arg('message?', eatall => 1) { my $self = shift; my ( $channel, $message, $cinv ) = @_; my $chanobj = $self->get_channel_if_exists( $channel ) or return "No such channel $channel"; $chanobj->part( message => $message, on_parted => sub { $cinv->respond( "Parted $channel", level => 1 ); $chanobj->destroy; }, on_part_error => sub { $cinv->respond( "Cannot part $channel - $_[0]", level => 3 ); }, ); return; } sub command_query : Command_description("Open a private message window to a user") : Command_arg('nick') { my $self = shift; my ( $nick, $cinv ) = @_; my $userobj = $self->get_user_or_create( $nick ); $userobj->reify; # TODO: Focus it return; } sub command_msg : Command_description("Send a PRIVMSG to a target") : Command_arg('target') : Command_arg('text', eatall => 1) { my $self = shift; my ( $target, $text ) = @_; if( my $targetobj = $self->get_target_if_exists( $target ) ) { $targetobj->msg( $text ); } else { my $irc = $self->{irc}; $irc->send_message( "PRIVMSG", undef, $target, $text ); } return; } sub command_notice : Command_description("Send a NOTICE to a target") : Command_arg('target') : Command_arg('text', eatall => 1) { my $self = shift; my ( $target, $text ) = @_; if( my $targetobj = $self->get_target_if_exists( $target ) ) { $targetobj->notice( $text ); } else { my $irc = $self->{irc}; $irc->send_message( "NOTICE", undef, $target, $text ); } return; } sub command_quote : Command_description("Send a raw IRC command") : Command_arg('cmd') : Command_arg('args', collect => 1) { my $self = shift; my ( $cmd, $args ) = @_; my $irc = $self->{irc}; $irc->send_message( $cmd, undef, @$args ); return; } sub command_away : Command_description("Set AWAY message") : Command_arg('message', eatall => 1) { my $self = shift; my ( $message ) = @_; my $irc = $self->{irc}; length $message or $message = "away"; $irc->send_message( "AWAY", undef, $message ); return; } sub command_unaway : Command_description("Remove AWAY message") { my $self = shift; my $irc = $self->{irc}; $irc->send_message( "AWAY", undef ); return; } sub command_whois : Command_description("Send a WHOIS query") : Command_arg('user') { my $self = shift; my ( $user, $cinv ) = @_; my $irc = $self->{irc}; my $user_folded = $irc->casefold_name( $user ); $irc->send_message( "WHOIS", undef, $user ); my $f = ( $self->{whois_gate_f}{$user_folded} ||= Future->new ); $f->on_done( sub { my ( $data ) = @_; $cinv->respond( "WHOIS $user:" ); foreach my $datum ( @$data ) { my %d = %$datum; my $whois = delete $d{whois}; $cinv->respond( " $whois - " . join( " ", map { my $val = $d{$_}; # 'channels' comes as an ARRAY ref($val) eq "ARRAY" ? "$_=@{$d{$_}}" : "$_=$d{$_}" } sort keys %d ) ); } }); $f->on_fail( sub { my ( $failure ) = @_; $cinv->responderr( "Cannot WHOIS $user - $failure" ); }); return (); } use Circle::Collection name => 'channels', storage => 'methods', attrs => [ name => { desc => "name" }, autojoin => { desc => "JOIN automatically when connected", show => sub { $_ ? "yes" : "no" }, }, key => { desc => "join key" }, ], ; sub channels_list { my $self = shift; return map { $self->channels_get( $_ ) } sort keys %{ $self->{channels} }; } sub channels_get { my $self = shift; my ( $name ) = @_; my $chan = $self->get_channel_if_exists( $name ) or return undef; return { name => $chan->get_prop_name, ( map { $_ => $chan->{$_} } qw( autojoin key ) ), }; } sub channels_set { my $self = shift; my ( $name, $def ) = @_; my $chanobj = $self->get_channel_if_exists( $name ) or die "Missing channel $name for channels_set"; foreach (qw( autojoin key )) { $chanobj->{$_} = $def->{$_} if exists $def->{$_}; } } sub channels_add { my $self = shift; my ( $name, $def ) = @_; my $chanobj = $self->get_channel_or_create( $name ); $chanobj->reify; foreach (qw( autojoin key )) { $chanobj->{$_} = $def->{$_} if exists $def->{$_}; } } sub channels_del { my $self = shift; my ( $name, $def ) = @_; my $chanobj = $self->get_channel_if_exists( $name ) or return undef; $chanobj->destroy; } sub commandable_parent { my $self = shift; return $self->{root}; } sub enumerable_name { my $self = shift; return $self->get_prop_tag; } sub parent { my $self = shift; return $self->{root}; } sub enumerate_items { my $self = shift; my %all = ( %{ $self->{channels} }, %{ $self->{users} } ); # Filter only the real ones $all{$_}->get_prop_real or delete $all{$_} for keys %all; return { map { $_->enumerable_name => $_ } values %all }; } sub get_item { my $self = shift; my ( $name, $create ) = @_; foreach my $items ( $self->{channels}, $self->{users} ) { return $items->{$name} if exists $items->{$name} and $items->{$name}->get_prop_real; } return $self->get_target_or_create( $name ) if $create; return undef; } __PACKAGE__->APPLY_Setting( local_host => description => "Local bind address", type => 'str', ); __PACKAGE__->APPLY_Setting( nick => description => "Initial connection nick", type => 'str', storage => 'configured_nick', ); __PACKAGE__->APPLY_Setting( use_mirc_colours => description => "Use mIRC colouring information", type => 'bool', default => 1, ); ### # Widgets ### sub get_widget_statusbar { my $self = shift; my $registry = $self->{registry}; my $statusbar = $registry->construct( "Circle::Widget::Box", classes => [qw( status )], orientation => "horizontal", ); $statusbar->add( $self->get_widget_netname ); my $nicklabel = $registry->construct( "Circle::Widget::Label", classes => [qw( nick )], ); $self->watch_property( "nick", on_updated => sub { $nicklabel->set_prop_text( $_[1] ) } ); $statusbar->add( $nicklabel ); my $awaylabel = $registry->construct( "Circle::Widget::Label", classes => [qw( away )], ); $self->watch_property( "away", on_updated => sub { $awaylabel->set_prop_text( $_[1] ? "[AWAY]" : "" ) } ); $statusbar->add( $awaylabel ); return $statusbar; } sub get_widget_channel_completegroup { my $self = shift; return $self->{widget_channel_completegroup} ||= do { my $registry = $self->{registry}; my $widget = $registry->construct( "Circle::Widget::Entry::CompleteGroup", ); # Have to cache id->name so we can delete properly # TODO: Consider fixing on_del my %id_to_name; $self->watch_property( "channels", on_set => sub { my ( undef, $channels ) = @_; $widget->set( map { $id_to_name{$_->id} = $_->name } values %$channels ); }, on_add => sub { my ( undef, $added ) = @_; $widget->add( $id_to_name{$added->id} = $added->name ); }, on_del => sub { my ( undef, $deleted_id ) = @_; $widget->remove( delete $id_to_name{$deleted_id} ); }, ); $widget->set( keys %{ $self->{channels} } ); $widget; }; } sub add_entry_widget_completegroups { my $self = shift; my ( $entry ) = @_; $entry->add_prop_completions( $self->get_widget_channel_completegroup ); } sub get_widget_commandentry { my $self = shift; my $widget = $self->SUPER::get_widget_commandentry; $self->add_entry_widget_completegroups( $widget ); return $widget; } 0x55AA; circle-be-0.173320/lib/Circle/Net/Raw.pm000444001750001750 1455213207602007 16264 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2012 -- leonerd@leonerd.org.uk package Circle::Net::Raw; use strict; use warnings; use base qw( Tangence::Object Circle::WindowItem Circle::Ruleable ); __PACKAGE__->APPLY_Ruleable; our $VERSION = '0.173320'; use constant NETTYPE => 'raw'; use base qw( Circle::Rule::Store ); # for the attributes use Text::Balanced qw( extract_delimited ); use Circle::TaggedString; use Circle::Widget::Box; use Circle::Widget::Label; sub new { my $class = shift; my %args = @_; my $self = $class->SUPER::new( %args ); $self->{loop} = $args{loop}; $self->{root} = $args{root}; $self->set_prop_tag( $args{tag} ); $self->{host} = undef; $self->{port} = undef; $self->{echo} = 1; my $rulestore = $self->init_rulestore( parent => $args{root}->{rulestore} ); $rulestore->register_action( "sendline" => $self ); $rulestore->new_chain( "input" ); $rulestore->new_chain( "output" ); $rulestore->new_chain( "connected" ); return $self; } sub describe { my $self = shift; return __PACKAGE__."[" . $self->get_prop_tag . "]"; } sub parse_action_sendline : Rule_description("Send a line of text to the peer") : Rule_format('$text') { my $self = shift; my ( $spec ) = @_; my $text = extract_delimited( $spec, q{"} ); # Trim leading and trailing " s/^"//, s/"$// for $text; # Unescape intermediate \\ and \" $text =~ s/\\([\\"])/$1/g; return $text; } sub deparse_action_sendline { my $self = shift; my ( $text ) = @_; $text =~ s/([\\"])/\\$1/g; return qq{"$text"}; } sub eval_action_sendline { my $self = shift; my ( $event, $results, $text ) = @_; if( my $conn = $self->{conn} ) { $conn->write( "$text\r\n" ); } } sub command_connect : Command_description("Connect to the server") : Command_arg('host?') : Command_arg('port?') { my $self = shift; my ( $host, $port, $cinv ) = @_; $host ||= $self->{host}; $port ||= $self->{port}; # 0 is not a valid TCP port defined $host or return $cinv->responderr( "Cannot connect - no host defined" ); defined $port or return $cinv->responderr( "Cannot connect - no port defined" ); my $loop = $self->{loop}; $loop->connect( host => $host, service => $port, socktype => 'stream', on_connected => sub { my ( $sock ) = @_; $cinv->respond( "Connected to $host:$port", level => 1 ); my $conn = $self->{conn} = IO::Async::Stream->new( handle => $sock, on_read => sub { my ( undef, $buffref, $closed ) = @_; return 0 unless $$buffref =~ s/^([^\r\n]*)\r?\n//; $self->incoming_text( $1 ); return 1; }, on_closed => sub { $self->push_displayevent( "status", { text => "Connection closed by peer" } ); $self->set_prop_connected(0); $self->fire_event( disconnected => ); undef $self->{conn}; }, ); $loop->add( $conn ); $self->run_rulechain( "connected" ); $self->set_prop_connected(1); $self->fire_event( connected => $host, $port ); }, on_resolve_error => sub { $cinv->responderr( "Unable to resolve $host:$port - $_[0]", level => 3 ); }, on_connect_error => sub { $cinv->responderr( "Unable to connect to $host:$port", level => 3 ); }, ); return; } sub command_discon : Command_description( "Disconnect TCP port" ) { my $self = shift; my ( $cinv ) = @_; if( my $conn = $self->{conn} ) { $conn->close; undef $self->{conn}; $cinv->respond( "Disconnected", level => 1 ); } else { $cinv->responderr( "Not connected" ); } return; } sub connected { my $self = shift; defined $self->{conn}; } sub command_close : Command_description("Disconnect and close the window") { my $self = shift; if( my $conn = $self->{conn} ) { $conn->close; undef $self->{conn}; } $self->destroy; } sub do_send { my $self = shift; my ( $text ) = @_; # TODO: Line separator if( my $conn = $self->{conn} ) { my $event = { text => Circle::TaggedString->new( $text ), }; $self->run_rulechain( "output", $event ); my $str = $event->{text}->str; $conn->write( "$str\r\n" ); $self->push_displayevent( "text", { text => $event->{text} } ) if $self->{echo}; } else { $self->responderr( "Not connected" ); } } sub enter_text { my $self = shift; my ( $text ) = @_; $self->do_send( $text ); } sub command_send : Command_description('Send a line of text') : Command_arg('text', eatall => 1) { my $self = shift; my ( $text, $cinv ) = @_; $self->do_send( $text ); } sub incoming_text { my $self = shift; my ( $text ) = @_; my $event = { text => Circle::TaggedString->new( $text ), level => 2, }; $self->run_rulechain( "input", $event ); $self->push_displayevent( "text", { text => $event->{text} } ); $self->bump_level( $event->{level} ) if defined $event->{level}; } sub commandable_parent { my $self = shift; return $self->{root}; } sub enumerable_name { my $self = shift; return $self->get_prop_tag; } sub parent { my $self = shift; return $self->{root}; } __PACKAGE__->APPLY_Setting( host => description => "Hostname of the server", type => 'str', ); __PACKAGE__->APPLY_Setting( port => description => "Port number of the server", type => 'int', ); __PACKAGE__->APPLY_Setting( echo => description => "Local line echo", type => 'bool', ); ### # Widgets ### sub get_widget_statusbar { my $self = shift; my $registry = $self->{registry}; my $statusbar = $registry->construct( "Circle::Widget::Box", classes => [qw( status )], orientation => "horizontal", ); my $serverlabel = $registry->construct( "Circle::Widget::Label", classes => [qw( label )], ); $self->subscribe_event( connected => sub { my ( $self, $host, $port ) = @_; $serverlabel->set_prop_text( "$host:$port" ); } ); $self->subscribe_event( disconnected => sub { $serverlabel->set_prop_text( "--unconnected--" ); } ); $statusbar->add( $serverlabel ); return $statusbar; } 0x55AA; circle-be-0.173320/lib/Circle/Net/IRC000755001750001750 013207602007 15426 5ustar00leoleo000000000000circle-be-0.173320/lib/Circle/Net/IRC/Channel.pm000444001750001750 5143713207602007 17523 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2017 -- leonerd@leonerd.org.uk package Circle::Net::IRC::Channel; use strict; use warnings; use 5.010; # // use base qw( Circle::Net::IRC::Target ); our $VERSION = '0.173320'; use Carp; use Circle::TaggedString; use Circle::Widget::Box; use Circle::Widget::Entry; use Circle::Widget::Label; use POSIX qw( strftime ); sub init_prop_occupant_summary { return { total => 0 }; } sub on_connected { my $self = shift; $self->SUPER::on_connected; if( $self->{autojoin} ) { $self->join( on_joined => sub { } ); } } sub join { my $self = shift; my %args = @_; my $on_joined = $args{on_joined}; ref $on_joined eq "CODE" or croak "Expected 'on_joined' as CODE ref"; my $key = $args{key} // $self->{key}; my $net = $self->{net}; $net->do_join( $self->get_prop_name, $key ); $self->{on_joined} = $on_joined; $self->{on_join_error} = $args{on_join_error}; } sub invite { my $self = shift; my ( $nick ) = @_; my $irc = $self->{irc}; # INVITE user #channel $irc->send_message( "INVITE", undef, $nick, $self->get_prop_name ); } sub kick { my $self = shift; my ( $nick, $message ) = @_; my $irc = $self->{irc}; $irc->send_message( "KICK", undef, $self->get_prop_name, $nick, $message ); } sub mode { my $self = shift; my ( $modestr, @args ) = @_; my $irc = $self->{irc}; $irc->send_message( "MODE", undef, $self->get_prop_name, $modestr, @args ); } sub method_mode { my $self = shift; my $ctx = shift; my ( $modestr, $argsarray ) = @_; $self->mode( $modestr, @$argsarray ); } sub part { my $self = shift; my %args = @_; my $on_parted = $args{on_parted}; ref $on_parted eq "CODE" or croak "Expected 'on_parted' as CODE ref"; my $irc = $self->{irc}; $irc->send_message( "PART", undef, $self->get_prop_name, defined $args{message} ? $args{message} : ( "" ) ); $self->{on_parted} = $on_parted; } sub topic { my $self = shift; my ( $topic ) = @_; my $irc = $self->{irc}; $irc->send_message( "TOPIC", undef, $self->get_prop_name, $topic ); } sub method_topic { my $self = shift; my $ctx = shift; $self->topic( @_ ); } sub user_leave { my $self = shift; my ( $nick_folded ) = @_; $self->del_prop_occupants( $nick_folded ); $self->post_update_occupants; } sub gen_modestr { my $self = shift; # This is a dynamic property my $mode = $self->get_prop_mode; # Order the mode as the server declares my $irc = $self->{irc}; my $channelmodes = $irc->server_info( "channelmodes" ); my @modes = sort { index( $channelmodes, $a ) <=> index( $channelmodes, $b ) } keys %$mode; my $str = "+"; my @args; foreach my $modechar ( @modes ) { $str .= $modechar; push @args, $mode->{$modechar} if length $mode->{$modechar}; } return CORE::join( " ", $str, @args ); } sub apply_modes { my $self = shift; my ( $modes ) = @_; my @mode_added; my @mode_deleted; my $irc = $self->{irc}; my $PREFIX_FLAGS = $irc->isupport( "prefix_flags" ); foreach my $m ( @$modes ) { my ( $type, $sense, $mode ) = @{$m}{qw( type sense mode )}; my $pm = $sense > 0 ? "+" : $sense < 0 ? "-" : ""; if( !defined $type ) { print STDERR "TODO: Undefined type for chanmode $mode\n"; } elsif( $type eq 'list' ) { print STDERR "TODO: A list chanmode $pm$mode $m->{value}\n"; } elsif( $type eq 'occupant' ) { my $flag = $m->{flag}; my $nick_folded = $m->{nick_folded}; my $occupant = $self->get_prop_occupants->{$nick_folded}; if( $sense > 0 ) { my $flags = $occupant->{flag} . $flag; # Now sort by PREFIX_FLAGS order $flags = CORE::join( "", sort { index( $PREFIX_FLAGS, $a ) <=> index( $PREFIX_FLAGS, $b ) } split( m//, $flags ) ); $occupant->{flag} = $flags; } else { $occupant->{flag} =~ s/\Q$flag//g; } # We're not adding it, we're changing it $self->add_prop_occupants( $nick_folded => $occupant ); $self->post_update_occupants; } elsif( $type eq 'value' ) { if( $sense > 0 ) { push @mode_added, [ $mode, $m->{value} ]; } else { push @mode_deleted, $mode; } } elsif( $type eq 'bool' ) { if( $sense > 0 ) { push @mode_added, [ $mode, "" ]; } else { push @mode_deleted, $mode; } } } if( @mode_added ) { # TODO: Allow CHANGE_ADD messages to add multiple key/value pairs foreach my $m ( @mode_added ) { $self->add_prop_mode( $m->[0] => $m->[1] ); } } if( @mode_deleted ) { $self->del_prop_mode( $_ ) for @mode_deleted; } if( @mode_added or @mode_deleted or !defined $self->get_prop_modestr ) { $self->set_prop_modestr( $self->gen_modestr ); } } sub post_update_occupants { my $self = shift; my $irc = $self->{irc}; my %count = map { $_ => 0 } "total", "", split( m//, $irc->isupport( "prefix_flags" ) ); my $myflag; foreach my $occ ( values %{ $self->get_prop_occupants } ) { unless( defined $occ->{nick} ) { warn "Have an undefined nick in $occ in $self\n"; next; } unless( defined $occ->{flag} ) { warn "Have an undefined flag for nick $occ->{nick} in $occ in $self\n"; next; } my $flag = $occ->{flag} =~ m/^(.)/ ? $1 : ""; $count{total}++; $count{$flag}++; $myflag = $flag if $irc->is_nick_me( $occ->{nick} ); } $self->set_prop_occupant_summary( \%count ); # Efficient application of property change my $old_myflag = $self->get_prop_my_flag; $self->set_prop_my_flag( $myflag ) if !defined $old_myflag or $old_myflag ne $myflag; } sub on_message_JOIN { my $self = shift; my ( $message, $hints ) = @_; my $nick = $hints->{prefix_nick}; my $userhost = "$hints->{prefix_user}\@$hints->{prefix_host}"; if( $hints->{prefix_is_me} ) { $self->{on_joined}->( $self ); $self->fire_event( "self_joined" ); $self->push_displayevent( "irc.join", { channel => $self->get_prop_name, nick => $nick, userhost => $userhost } ); $self->bump_level( 1 ); # Request the initial mode my $irc = $self->{irc}; $irc->send_message( "MODE", undef, $self->get_prop_name ); } else { $self->fire_event( "join", $nick ); $self->push_displayevent( "irc.join", { channel => $self->get_prop_name, nick => $nick, userhost => $userhost } ); $self->bump_level( 1 ); my $nick_folded = $hints->{prefix_nick_folded}; my $newocc = { nick => $nick, flag => "" }; $self->add_prop_occupants( $nick_folded => $newocc ); $self->post_update_occupants; } return 1; } sub on_message_KICK { my $self = shift; my ( $message, $hints ) = @_; my $kicker = $hints->{kicker_nick}; my $kicked = $hints->{kicked_nick}; my $kickmsg = $hints->{text}; defined $kickmsg or $kickmsg = ""; my $net = $self->{net}; my $kickmsg_formatted = $net->format_text( $kickmsg ); my $irc = $self->{irc}; if( $irc->is_nick_me( $kicked ) ) { $self->fire_event( "self_parted" ); $self->push_displayevent( "irc.kick", { channel => $self->get_prop_name, kicker => $kicker, kicked => $kicked, kickmsg => $kickmsg_formatted } ); $self->bump_level( 1 ); } else { $self->fire_event( "kick", $kicker, $kicked, $kickmsg ); $self->push_displayevent( "irc.kick", { channel => $self->get_prop_name, kicker => $kicker, kicked => $kicked, kickmsg => $kickmsg_formatted } ); $self->bump_level( 1 ); $self->user_leave( $hints->{kicked_nick_folded} ); } return 1; } sub on_message_MODE { my $self = shift; my ( $message, $hints ) = @_; my $modes = $hints->{modes}; my $nick; my $userhost; if( defined $hints->{prefix_nick} ) { $nick = $hints->{prefix_nick}; $userhost = "$hints->{prefix_user}\@$hints->{prefix_host}"; } else { $nick = $userhost = $hints->{prefix_host}; } $self->apply_modes( $hints->{modes} ); my $modestr = CORE::join( " ", $hints->{modechars}, @{ $hints->{modeargs} } ); # 'nick' for legacy purposes, 'moder' for new $self->push_displayevent( "irc.mode", { channel => $self->get_prop_name, nick => $nick, moder => $nick, userhost => $userhost, mode => $modestr, } ); $self->bump_level( 1 ); return 1; } sub on_message_NICK { my $self = shift; my ( $message, $hints ) = @_; my $oldnick_folded = $hints->{old_nick_folded}; return 0 unless my $occ = $self->get_prop_occupants->{$oldnick_folded}; my $oldnick = $hints->{old_nick}; my $newnick = $hints->{new_nick}; $self->push_displayevent( "irc.nick", { channel => $self->get_prop_name, oldnick => $oldnick, newnick => $newnick } ); $self->bump_level( 1 ); my $newnick_folded = $hints->{new_nick_folded}; $self->del_prop_occupants( $oldnick_folded ); $occ->{nick} = $newnick; $self->add_prop_occupants( $newnick_folded => $occ ); $self->post_update_occupants; return 1; } sub on_message_PART { my $self = shift; my ( $message, $hints ) = @_; my $nick = $hints->{prefix_nick}; my $partmsg = $hints->{text}; defined $partmsg or $partmsg = ""; my $net = $self->{net}; my $partmsg_formatted = $net->format_text( $partmsg ); my $userhost = "$hints->{prefix_user}\@$hints->{prefix_host}"; if( $hints->{prefix_is_me} ) { $self->fire_event( "self_parted" ); $self->push_displayevent( "irc.part", { channel => $self->get_prop_name, nick => $nick, userhost => $userhost, partmsg => $partmsg_formatted } ); $self->bump_level( 1 ); $self->{on_parted}->( $self ); } else { $self->fire_event( "part", $nick, $partmsg ); $self->push_displayevent( "irc.part", { channel => $self->get_prop_name, nick => $nick, userhost => $userhost, partmsg => $partmsg_formatted } ); $self->bump_level( 1 ); $self->user_leave( $hints->{prefix_nick_folded} ); } return 1; } sub on_message_QUIT { my $self = shift; my ( $message, $hints ) = @_; my $nick_folded = $hints->{prefix_nick_folded}; return 0 unless $self->get_prop_occupants->{$nick_folded}; my $nick = $hints->{prefix_nick}; my $quitmsg = $hints->{text}; defined $quitmsg or $quitmsg = ""; my $net = $self->{net}; my $quitmsg_formatted = $net->format_text( $quitmsg ); my $userhost = "$hints->{prefix_user}\@$hints->{prefix_host}"; $self->push_displayevent( "irc.quit", { channel => $self->get_prop_name, nick => $nick, userhost => $userhost, quitmsg => $quitmsg_formatted } ); $self->bump_level( 1 ); $self->user_leave( $nick_folded ); return 1; } sub on_message_TOPIC { my $self = shift; my ( $message, $hints ) = @_; my $topic = $hints->{text}; $self->set_prop_topic( $topic ); my $nick = $hints->{prefix_name}; my $userhost = "$hints->{prefix_user}\@$hints->{prefix_host}"; $self->fire_event( "topic", $nick, $topic ); $self->push_displayevent( "irc.topic", { channel => $self->get_prop_name, nick => $nick, userhost => $userhost, topic => $topic } ); $self->bump_level( 1 ); return 1; } sub on_message_RPL_CHANNELMODEIS { my $self = shift; my ( $message, $hints ) = @_; $self->apply_modes( $hints->{modes} ); my $modestr = CORE::join( " ", $hints->{modechars}, @{ $hints->{modeargs} } ); $self->push_displayevent( "irc.mode_is", { channel => $self->get_prop_name, mode => $modestr } ); $self->bump_level( 1 ); return 1; } sub on_message_RPL_NOTOPIC { my $self = shift; my ( $message, $hints ) = @_; $self->set_prop_topic( "" ); return 1; } sub on_message_RPL_TOPIC { my $self = shift; my ( $message, $hints ) = @_; my $topic = $hints->{text}; $self->set_prop_topic( $topic ); $self->fire_event( "topic", undef, $topic ); $self->push_displayevent( "irc.topic_is", { channel => $self->get_prop_name, topic => $topic } ); $self->bump_level( 1 ); return 1; } sub on_message_RPL_TOPICWHOTIME { my $self = shift; my ( $message, $hints ) = @_; my $timestr = strftime "%Y/%m/%d %H:%M:%S", localtime $hints->{timestamp}; $self->push_displayevent( "irc.topic_by", { channel => $self->get_prop_name, topic_by => $hints->{topic_nick}, timestamp => $timestr } ); $self->bump_level( 1 ); return 1; } sub on_message_RPL_CHANNEL_URL { my $self = shift; my ( $message, $hints ) = @_; $self->push_displayevent( "irc.text", { server => $hints->{prefix_host}, text => "URL: $hints->{text}" } ); $self->bump_level( 1 ); return 1; } sub on_message_RPL_CHANNELCREATED { my $self = shift; my ( $message, $hints ) = @_; my $timestr = strftime "%Y/%m/%d %H:%M:%S", localtime $hints->{timestamp}; $self->push_displayevent( "irc.text", { server => $hints->{prefix_host}, text => "Channel created $timestr" } ); $self->bump_level( 1 ); return 1; } sub on_message_names { my $self = shift; my ( $message, $hints ) = @_; $self->set_prop_occupants( $hints->{names} ); $self->post_update_occupants; return 1; } sub command_part : Command_description("Part the channel") : Command_arg('message?', eatall => 1) { my $self = shift; my ( $message, $cinv ) = @_; $self->part( message => $message, on_parted => sub { $cinv->respond( "Parted", level => 1 ); $self->destroy; }, on_part_error => sub { $cinv->responderr( "Cannot part - $_[0]", level => 3 ); }, ); return; } sub command_mode : Command_description("Change a MODE") : Command_arg('mode') : Command_arg('args', collect => 1) { my $self = shift; my ( $mode, $args ) = @_; $self->mode( $mode, @$args ); return; } sub command_topic : Command_description("Change the TOPIC") : Command_arg('topic?', eatall => 1) { my $self = shift; my ( $topic ) = @_; if( length $topic ) { $self->topic( $topic ); } else { $self->push_displayevent( "irc.topic_is", { channel => $self->get_prop_name, topic => $self->get_prop_topic } ); } return; } sub command_names : Command_description("Print a list of users in the channel") : Command_opt('flat=+', desc => "all types of users in one flat list") { my $self = shift; my ( $opts, $cinv ) = @_; my $occ = $self->get_prop_occupants; if( $opts->{flat} ) { my @names = map { "$occ->{$_}{flag}$occ->{$_}{nick}" } sort keys %$occ; $cinv->respond( "Names: " . CORE::join( " ", @names ) ); return; } # Split into groups per flag my %occgroups; for my $nick_folded ( keys %$occ ) { my $flag = substr( $occ->{$nick_folded}{flag}, 0, 1 ); # In case user has several push @{ $occgroups{ $flag } }, $nick_folded; } # TODO: Ought to obtain this from somewhere - NaIRC maybe? my %flag_to_desc = ( '~' => "Founder", '&' => "Admin", '@' => "Operator", '%' => "Halfop", '+' => "Voice", '' => "User", ); my $irc = $self->{irc}; foreach my $flag ( sort { $irc->cmp_prefix_flags( $b, $a ) } keys %occgroups ) { my @names = map { "$flag$occ->{$_}{nick}" } sort @{ $occgroups{$flag} }; my $text = Circle::TaggedString->new( $flag_to_desc{$flag} . ": " ); $text->append_tagged( CORE::join( " ", @names ), indent => 1 ); $cinv->respond( $text ); } return; } sub command_op : Command_description("Give channel operator status to users") : Command_arg('users', collect => 1) { my $self = shift; my ( $users ) = @_; my @users = @$users; $self->mode( "+".("o"x@users), @users ); return; } sub command_deop : Command_description("Remove channel operator status from users") : Command_arg('users', collect => 1) { my $self = shift; my ( $users ) = @_; my @users = @$users; $self->mode( "-".("o"x@users), @users ); return; } sub command_halfop : Command_description("Give channel half-operator status to users") : Command_arg('users', collect => 1) { my $self = shift; my ( $users ) = @_; my @users = @$users; $self->mode( "+".("h"x@users), @users ); return; } sub command_dehalfop : Command_description("Remove channel half-operator status from users") : Command_arg('users', collect => 1) { my $self = shift; my ( $users ) = @_; my @users = @$users; $self->mode( "-".("h"x@users), @users ); return; } sub command_voice : Command_description("Give channel voice status to users") : Command_arg('users', collect => 1) { my $self = shift; my ( $users ) = @_; my @users = @$users; $self->mode( "+".("v"x@users), @users ); return; } sub command_devoice : Command_description("Remove channel voice status from users") : Command_arg('users', collect => 1) { my $self = shift; my ( $users ) = @_; my @users = @$users; $self->mode( "-".("v"x@users), @users ); return; } sub command_invite : Command_description("Invite a new user to the channel") : Command_arg('user') { my $self = shift; my ( $nick ) = @_; $self->invite( $nick ); return; } sub command_kick : Command_description("Kick a user from the channel") : Command_arg('user') : Command_arg('message?', eatall => 1 ) { my $self = shift; my ( $nick, $message ) = @_; $message = "" if !defined $message; $self->kick( $nick, $message ); return; } ### # Widget tree ### sub get_widget_statusbar { my $self = shift; my $registry = $self->{registry}; my $net = $self->{net}; my $statusbar = $registry->construct( "Circle::Widget::Box", classes => [qw( status )], orientation => "horizontal", ); $statusbar->add( $net->get_widget_netname ); my $nicklabel = $registry->construct( "Circle::Widget::Label", classes => [qw( nick )], ); # TODO: This is hideous... my $nick = $net->get_prop_nick || $net->{configured_nick}; my $my_flag = ""; my $updatenicklabel = sub { $nicklabel->set_prop_text( $my_flag . $nick ) }; $net->watch_property( "nick", on_set => sub { $nick = $_[1]; goto &$updatenicklabel } ); $self->watch_property( "my_flag", on_set => sub { $my_flag = $_[1]; goto &$updatenicklabel } ); $updatenicklabel->(); $statusbar->add( $nicklabel ); my $modestrlabel = $registry->construct( "Circle::Widget::Label", classes => [qw( mode )], ); $self->watch_property( "modestr", on_updated => sub { $modestrlabel->set_prop_text( $_[1] || "" ) } ); $statusbar->add( $modestrlabel ); $statusbar->add_spacer( expand => 1 ); my $countlabel = $registry->construct( "Circle::Widget::Label", classes => [qw( occupants )], ); $self->watch_property( "occupant_summary", on_updated => sub { my ( $self, $summary ) = @_; my $irc = $self->{irc}; my $PREFIX_FLAGS = $irc->isupport( "prefix_flags" ) || ""; my $str = "$summary->{total} users [" . CORE::join( " ", map { "$_$summary->{$_}" } grep { $summary->{$_}||0 > 0 } split( m//, $PREFIX_FLAGS ), "" ) . "]"; $countlabel->set_prop_text( $str ); } ); $statusbar->add( $countlabel ); return $statusbar; } sub get_widget_occupants_completegroup { my $self = shift; return $self->{widget_occupants_completegroup} ||= do { my $registry = $self->{registry}; my $widget = $registry->construct( "Circle::Widget::Entry::CompleteGroup", suffix_sol => ": ", ); my %key_to_nick; $self->watch_property( "occupants", on_set => sub { my ( undef, $occupants ) = @_; $widget->set( map { $key_to_nick{$_} = $occupants->{$_}{nick} } keys %$occupants ); }, on_add => sub { my ( undef, $key, $occ ) = @_; $widget->add( $key_to_nick{$key} = $occ->{nick} ); }, on_del => sub { my ( undef, $key ) = @_; $widget->remove( delete $key_to_nick{$key} ); }, ); my $occupants = $self->get_prop_occupants; $widget->set( map { $key_to_nick{$_} = $occupants->{$_}{nick} } keys %$occupants ); $widget; }; } sub get_widget_commandentry { my $self = shift; my $widget = $self->SUPER::get_widget_commandentry; $widget->add_prop_completions( $self->get_widget_occupants_completegroup ); return $widget; } sub make_widget_pre_scroller { my $self = shift; my ( $box ) = @_; my $registry = $self->{registry}; my $topicentry = $registry->construct( "Circle::Widget::Entry", classes => [qw( topic )], on_enter => sub { $self->topic( $_[0] ) }, ); $self->watch_property( "topic", on_updated => sub { $topicentry->set_prop_text( $_[1] ) } ); $box->add( $topicentry ); } 0x55AA; circle-be-0.173320/lib/Circle/Net/IRC/Target.pm000444001750001750 1733013207602007 17373 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk package Circle::Net::IRC::Target; use strict; use warnings; use base qw( Tangence::Object Circle::WindowItem ); our $VERSION = '0.173320'; sub new { my $class = shift; my %args = @_; my $self = $class->SUPER::new( @_ ); $self->{irc} = $args{irc}; $self->set_prop_name( $args{name} ); $self->set_prop_tag( $args{name} ); $self->{root} = $args{root}; $self->{net} = $args{net}; return $self; } # Convenience accessor sub name { my $self = shift; return $self->get_prop_name; } use Scalar::Util qw( refaddr ); use overload # '""' => "STRING", '0+' => sub { refaddr $_[0] }, fallback => 1; use constant PREFIX_OVERHEAD => 3; use constant PRIVMSG_OVERHEAD => length("PRIVMSG :"); use constant CTCP_ACTION_OVERHEAD => length("PRIVMSG :\x01CTCP ACTION \x01"); sub STRING { my $self = shift; return ref($self)."[name=".$self->name."]"; } sub describe { my $self = shift; return ref($self) . "[" . $self->name . "]"; } sub get_prop_tag { my $self = shift; return $self->name; } sub get_prop_network { my $self = shift; return $self->{net}; } sub reify { my $self = shift; return if $self->get_prop_real; $self->set_prop_real( 1 ); my $root = $self->{root}; $root->broadcast_sessions( "new_item", $self ); } sub on_message { my $self = shift; my ( $command, $message, $hints ) = @_; # $command might contain spaces from synthesized events - e.g. "ctcp ACTION" ( my $method = "on_message_$command" ) =~ s/ /_/g; return 1 if $self->can( $method ) and $self->$method( $message, $hints ); if( not $hints->{handled} and not $hints->{synthesized} ) { $self->push_displayevent( "irc.irc", { command => $command, prefix => $message->prefix, args => join( " ", map { "'$_'" } $message->args ), } ); $self->bump_level( 1 ); } return 1; } sub pick_display_target { my $self = shift; my ( $display ) = @_; return $self if $display eq "self"; return $self->{net} if $display eq "server"; } sub default_message_level { my $self = shift; my ( $hints ) = @_; return $hints->{is_notice} ? 1 : 2; } sub on_message_text { my $self = shift; my ( $message, $hints ) = @_; my $srcnick = $hints->{prefix_name}; my $text = $hints->{text}; my $is_notice = $hints->{is_notice}; my $net = $self->{net}; my $event = { %$hints, text => $net->format_text_tagged( $text ), is_action => 0, level => $self->default_message_level( $hints ), display => ( !defined $hints->{prefix_nick} or $is_notice && !$self->get_prop_real ) ? "server" : "self", }; $net->run_rulechain( "input", $event ); my $eventname = $is_notice ? "notice" : "msg"; $self->fire_event( $eventname, $srcnick, $text ); if( my $target = $self->pick_display_target( $event->{display} ) ) { $target->push_displayevent( "irc.$eventname", { target => $self->name, nick => $srcnick, text => $event->{text} } ); $target->bump_level( $event->{level} ) if defined $event->{level}; $target->reify; } return 1; } sub on_message_ctcp_ACTION { my $self = shift; my ( $message, $hints ) = @_; my $srcnick = $hints->{prefix_name}; my $text = $hints->{ctcp_args}; my $net = $self->{net}; my $event = { %$hints, text => $net->format_text_tagged( $text ), is_action => 1, level => $self->default_message_level( $hints ), display => "self", }; $net->run_rulechain( "input", $event ); $self->fire_event( "act", $srcnick, $text ); if( my $target = $self->pick_display_target( $event->{display} ) ) { $target->push_displayevent( "irc.act", { target => $self->name, nick => $srcnick, text => $event->{text} } ); $target->bump_level( $event->{level} ) if defined $event->{level}; $target->reify; } return 1; } sub on_connected { my $self = shift; $self->push_displayevent( "status", { text => "Server is connected" } ); } sub on_disconnected { my $self = shift; my ( $message ) = @_; $self->push_displayevent( "status", { text => $message } ); } sub _split_text_chunks { my ( $text, $maxlen, $on_chunk ) = @_; my $head = "<< "; my $tail = " >>"; while( length $text ) { if( $maxlen >= length $text ) { $on_chunk->( $text ); return; } my $prefix = substr $text, 0, $maxlen - length( $tail ); if( $prefix =~ m/\s+\S+$/ ) { substr( $prefix, $-[0] ) = ""; } $on_chunk->( $prefix . $tail ); substr( $text, 0, length $prefix ) = ""; $text =~ s/^\s+//; substr( $text, 0, 0 ) = $head; } } sub msg { my $self = shift; my ( $text, %hints ) = @_; my $irc = $self->{irc}; my $net = $self->{net}; my $event = { text => Circle::TaggedString->new( $text ), is_action => $hints{action}, }; $net->run_rulechain( "output", $event ); my $is_action = $event->{is_action}; my $maxlen = 510 - # To work out the maximum message length size we'd need to know our own # prefix that the server will send. We can't know the host, but we know # everything else. Just pretend it's maximal length, 64 ( length( $irc->{nick} ) + length( $irc->{user} ) + 64 + PREFIX_OVERHEAD ); my $target = $self->name; foreach my $line ( split m/\n/, $event->{text}->str ) { if( $is_action ) { _split_text_chunks( $line, $maxlen - length($target) - CTCP_ACTION_OVERHEAD, sub { $irc->send_ctcp( undef, $target, "ACTION", $_[0] ); }); } else { _split_text_chunks( $line, $maxlen - length($target) - PRIVMSG_OVERHEAD, sub { $irc->send_message( "PRIVMSG", undef, $target, $_[0] ); }); } my $line_formatted = $net->format_text( $line ); $self->fire_event( $is_action ? "act" : "msg", $irc->nick, $line ); $self->push_displayevent( $is_action ? "irc.act" : "irc.msg", { target => $self->name, nick => $irc->nick, text => $line_formatted } ); } } sub method_msg { my $self = shift; my $ctx = shift; $self->msg( $_[0], action => 0 ); } sub notice { my $self = shift; my ( $text ) = @_; my $irc = $self->{irc}; $irc->send_message( "NOTICE", undef, $self->name, $text ); my $net = $self->{net}; my $text_formatted = $net->format_text( $text ); $self->fire_event( "notice", $irc->nick, $text ); $self->push_displayevent( "irc.notice", { target => $self->name, nick => $irc->nick, text => $text_formatted } ); } sub method_notice { my $self = shift; my $ctx = shift; $self->notice( @_ ); } sub method_act { my $self = shift; my $ctx = shift; $self->msg( $_[0], action => 1 ); } sub command_say : Command_description("Quote text directly as a PRIVMSG") : Command_arg('text', eatall => 1) { my $self = shift; my ( $text ) = @_; $self->msg( $text, action => 0 ); return; } sub command_me : Command_description("Send a CTCP ACTION") : Command_arg('text', eatall => 1) { my $self = shift; my ( $text ) = @_; $self->msg( $text, action => 1 ); return; } sub commandable_parent { my $self = shift; return $self->{net}; } sub enumerable_name { my $self = shift; return $self->get_prop_tag; } sub parent { my $self = shift; return $self->{net}; } sub enter_text { my $self = shift; my ( $text ) = @_; return unless length $text; $self->msg( $text ); } sub get_widget_commandentry { my $self = shift; my $widget = $self->SUPER::get_widget_commandentry; $self->{net}->add_entry_widget_completegroups( $widget ); return $widget; } 0x55AA; circle-be-0.173320/lib/Circle/Net/IRC/User.pm000444001750001750 1310413207602007 17056 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2016 -- leonerd@leonerd.org.uk package Circle::Net::IRC::User; use strict; use warnings; use base qw( Circle::Net::IRC::Target ); our $VERSION = '0.173320'; use Carp; # Don't reprint RPL_USERISAWAY message within 1 hour # TODO: Some sort of config setting system my $awaytime_print = 3600; sub default_message_level { my $self = shift; my ( $hints ) = @_; return 3; } sub on_message { my $self = shift; my ( $command, $message, $hints ) = @_; # Messages from the user will have a prefix_user hint, server messages will not. if( defined( my $ident = $hints->{prefix_user} ) ) { my $hostname = $hints->{prefix_host}; $self->update_ident( "$ident\@$hostname" ); } return $self->SUPER::on_message( @_ ); } sub update_ident { my $self = shift; my ( $ident ) = @_; return if defined $self->get_prop_ident and $self->get_prop_ident eq $ident; $self->set_prop_ident( $ident ); } sub on_message_NICK { my $self = shift; my ( $message, $hints ) = @_; my $oldnick = $self->name; my $newnick = $hints->{new_nick}; $self->push_displayevent( "irc.nick", { oldnick => $oldnick, newnick => $newnick } ); $self->bump_level( 1 ); $self->set_prop_name( $newnick ); $self->set_prop_tag( $newnick ); my $oldnick_folded = $self->{irc}->casefold_name( $oldnick ); $self->fire_event( "change_nick", $oldnick, $oldnick_folded, $newnick, $hints->{new_nick_folded} ); return 1; } sub on_message_QUIT { my $self = shift; my ( $message, $hints ) = @_; my $nick = $self->name; my $quitmsg = $hints->{text}; defined $quitmsg or $quitmsg = ""; my $net = $self->{net}; my $quitmsg_formatted = $net->format_text( $quitmsg ); my $userhost = "$hints->{prefix_user}\@$hints->{prefix_host}"; $self->push_displayevent( "irc.quit", { nick => $nick, userhost => $userhost, quitmsg => $quitmsg_formatted } ); $self->bump_level( 1 ); return 1; } sub on_message_RPL_AWAY { my $self = shift; my ( $message, $hints ) = @_; my $nick = $self->name; my $awaymsg = $hints->{text}; defined $awaymsg or $awaymsg = ""; # Surpress the message if it's already been printed and it's quite soon my $now = time; if( defined $self->{printed_awaymsg} and $self->{printed_awaymsg} eq $awaymsg and $now < $self->{printed_awaytime} + $awaytime_print ) { return 1; } my $net = $self->{net}; my $awaymsg_formatted = $net->format_text( $awaymsg ); my $userhost = "$hints->{prefix_user}\@$hints->{prefix_host}"; $self->push_displayevent( "irc.away", { nick => $nick, userhost => $userhost, text => $awaymsg_formatted } ); $self->bump_level( 1 ); $self->{printed_awaymsg} = $awaymsg; $self->{printed_awaytime} = $now; return 1; } sub on_message_RPL_LOGON { my $self = shift; $self->on_message_RPL_NOWON( @_ ); my $nick = $self->name; $self->push_displayevent( "irc.online", { nick => $nick } ); $self->bump_level( 1 ); return 1; } sub on_message_RPL_LOGOFF { my $self = shift; $self->on_message_RPL_NOWOFF( @_ ); my $nick = $self->name; $self->push_displayevent( "irc.offline", { nick => $nick } ); $self->bump_level( 1 ); return 1; } sub on_message_RPL_NOWON { my $self = shift; $self->set_prop_presence( "online" ); return 1; } sub on_message_RPL_NOWOFF { my $self = shift; $self->set_prop_presence( "offline" ); return 1; } # Send it back sub on_message_whois { my $self = shift; my ( $message, $hints ) = @_; my $net = $self->{net}; $net->on_message_whois( $message, $hints ); } sub command_close : Command_description("Close the window") { my $self = shift; $self->destroy; } sub command_requery : Command_description("Change the target nick for this user query") : Command_arg('newnick') { my $self = shift; my ( $newnick ) = @_; my $oldnick = $self->name; $self->set_prop_name( $newnick ); $self->set_prop_tag( $newnick ); my $oldnick_folded = $self->{irc}->casefold_name( $oldnick ); my $newnick_folded = $self->{irc}->casefold_name( $newnick ); $self->fire_event( "change_nick", $oldnick, $oldnick_folded, $newnick, $newnick_folded ); return ( "Now talking to $newnick" ); } sub command_whois : Command_description("Send a WHOIS query") : Command_arg('user?') { my $self = shift; my ( $user, $cinv ) = @_; $user //= $self->name; $self->{net}->command_whois( $user, $cinv ); } sub make_widget_pre_scroller { my $self = shift; my ( $box ) = @_; my $registry = $self->{registry}; my $identlabel = $registry->construct( "Circle::Widget::Label", classes => [qw( ident )], ); $self->watch_property( "ident", on_updated => sub { $identlabel->set_prop_text( $_[1] ) } ); $box->add( $identlabel ); } sub get_widget_presence { my $self = shift; my $registry = $self->{registry}; my $presencelabel = $registry->construct( "Circle::Widget::Label", classes => [qw( presence )], ); $self->watch_property( "presence", on_updated => sub { $presencelabel->set_prop_text( "($_[1])" ) }, ); return $presencelabel; } sub get_widget_statusbar { my $self = shift; my $registry = $self->{registry}; my $net = $self->{net}; my $statusbar = $registry->construct( "Circle::Widget::Box", classes => [qw( status )], orientation => "horizontal", ); $statusbar->add( $net->get_widget_netname ); $statusbar->add( $self->get_widget_presence ); return $statusbar; } 0x55AA; circle-be-0.173320/lib/Circle/Rule000755001750001750 013207602007 15172 5ustar00leoleo000000000000circle-be-0.173320/lib/Circle/Rule/Chain.pm000444001750001750 472413207602007 16716 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2010 -- leonerd@leonerd.org.uk package Circle::Rule::Chain; use strict; use warnings; our $VERSION = '0.173320'; use Circle::Rule::Resultset; sub new { my $class = shift; my ( $store ) = @_; my $self = bless { store => $store, rules => [], }, $class; return $self; } sub parse_rule { my $self = shift; my ( $spec ) = @_; my $store = $self->{store}; my @conds; while( length $spec and $spec !~ m/^:/ ) { push @conds, $store->parse_cond( $spec ); $spec =~ s/^\s+//; # trim ws } $spec =~ s/^:\s*// or die "Expected ':' to separate condition and action\n"; my @actions; while( length $spec ) { push @actions, $store->parse_action( $spec ); $spec =~ s/^\s+//; # trim ws } @actions or die "Expected at least one action\n"; return [ \@conds, \@actions ]; } sub append_rule { my $self = shift; my ( $spec ) = @_; push @{ $self->{rules} }, $self->parse_rule( $spec ); } sub insert_rule { my $self = shift; my ( $index, $spec ) = @_; # TODO: Consider what happens if index is OOB splice @{ $self->{rules} }, $index, 0, $self->parse_rule( $spec ); } sub delete_rule { my $self = shift; my ( $index ) = @_; $index < @{ $self->{rules} } or die "No rule at index $index\n"; splice @{ $self->{rules} }, $index, 1, (); } sub clear { my $self = shift; @{ $self->{rules} } = (); } sub deparse_rules { my $self = shift; my $store = $self->{store}; my @ret; foreach my $rule ( @{ $self->{rules} } ) { my ( $conds, $actions ) = @$rule; push @ret, join( " ", map { $store->deparse_cond( $_ ) } @$conds ) . ": " . join( " ", map { $store->deparse_action( $_ ) } @$actions ); } return @ret; } sub run { my $self = shift; my ( $event ) = @_; my $store = $self->{store}; RULE: foreach my $rule ( @{ $self->{rules} } ) { my ( $conds, $actions ) = @$rule; my $results = Circle::Rule::Resultset->new(); foreach my $cond ( @$conds ) { $store->eval_cond( $cond, $event, $results ) or next RULE; } # We've got this far - run the actions foreach my $action ( @$actions ) { # TODO: Consider eval{} wrapping $store->eval_action( $action, $event, $results ); } # All rules are independent - for now at least } } 0x55AA; circle-be-0.173320/lib/Circle/Rule/Resultset.pm000444001750001750 254713207602007 17667 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2010 -- leonerd@leonerd.org.uk package Circle::Rule::Resultset; use strict; use warnings; our $VERSION = '0.173320'; use Carp; sub new { my $class = shift; return bless {}, $class; } sub get_result { my $self = shift; my ( $name ) = @_; carp "No result '$name'" unless exists $self->{$name}; return $self->{$name}; } sub push_result { my $self = shift; my ( $name, $value ) = @_; if( !exists $self->{$name} ) { $self->{$name} = [ $value ]; } elsif( ref $self->{$name} eq "ARRAY" ) { push @{ $self->{$name} }, $value; } else { croak "Expected '$name' to be an ARRAY result"; } } sub merge_from { my $self = shift; my ( $other ) = @_; foreach my $name ( %$other ) { my $otherval = $other->{$name}; if( !$self->{$name} ) { $self->{$name} = $otherval; next; } my $myval = $self->{$name}; # Already had it - type matches? if( ref $myval ne ref $otherval ) { croak "Cannot merge; '$name' has different result types"; } my $type = ref $myval; if( ref $myval eq "ARRAY" ) { push @$myval, @$otherval; } else { croak "Don't know how to handle result type '$name' ($type)"; } } } 0x55AA; circle-be-0.173320/lib/Circle/Rule/Store.pm000444001750001750 2063313207602007 17005 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2010 -- leonerd@leonerd.org.uk package Circle::Rule::Store; use strict; use warnings; our $VERSION = '0.173320'; use Carp; use Circle::Rule::Chain; use Circle::Rule::Resultset; use Text::Balanced qw( extract_bracketed ); use Attribute::Storage qw( get_subattrs ); ############################################# ### Attribute handlers for command_* subs ### ############################################# sub Rule_description :ATTR(CODE) { my $class = shift; my ( $text ) = @_; return $text; } sub Rule_format :ATTR(CODE) { my $class = shift; my ( $format ) = @_; return $format; } sub new { my $class = shift; my %args = @_; my $self = bless { cond => {}, action => {}, parent => $args{parent}, chains => {}, }, $class; $self->register_cond( not => $self ); $self->register_cond( any => $self ); $self->register_cond( all => $self ); return $self; } sub register_cond { my $self = shift; my ( $name, $obj ) = @_; croak "Already have a condition function called $name" if exists $self->{cond}->{$name}; foreach my $method ( "parse_cond_$name", "deparse_cond_$name", "eval_cond_$name" ) { eval { $obj->can( $method ) } or croak "Expected that $obj can $method"; } $self->{cond}->{$name} = { obj => $obj }; } sub list_conds { my $self = shift; return ( keys %{ $self->{cond} } ), ( $self->{parent} ? $self->{parent}->list_conds : () ); } sub get_cond { my $self = shift; my ( $name ) = @_; return $self->{cond}->{$name} if $self->{cond}->{$name}; return $self->{parent}->get_cond( $name ) if $self->{parent}; die "No such condition '$name'\n"; } sub parse_cond { my $self = shift; # my ( $spec ) = @_ but we'll use $_[0] for alias $_[0] =~ s/^(\w+)\s*// or die "Expected a condition name\n"; my $condname = $1; my $cond = $self->get_cond( $condname ); my $condspec; if( $_[0] =~ m/^\(/ ) { $condspec = extract_bracketed( $_[0], q{("')} ); defined $condspec or die "Bad argument spec '$condspec' for condition $condname\n"; s/^\(\s*//, s/\s*\)$// for $condspec; } my $method = "parse_cond_$condname"; my @condargs = eval { $cond->{obj}->$method( $condspec ) }; if( $@ ) { my $err = $@; chomp $err; die "$err while parsing condition spec '$condspec' for $condname\n"; } return [ $condname, @condargs ]; } sub deparse_cond { my $self = shift; my ( $condref ) = @_; my ( $name, @args ) = @$condref; my $cond = $self->get_cond( $name ); my $method = "deparse_cond_$name"; my $argspec = $cond->{obj}->$method( @args ); return defined $argspec ? "$name($argspec)" : $name; } sub eval_cond { my $self = shift; my ( $condref, $event, $results ) = @_; my ( $name, @args ) = @$condref; my $cond = $self->get_cond( $name ); my $method = "eval_cond_$name"; return $cond->{obj}->$method( $event, $results, @args ); } sub describe_cond { my $self = shift; my ( $name ) = @_; my $cond = $self->get_cond( $name ); my $attrs = get_subattrs( $cond->{obj}->can( "parse_cond_$name" ) ); return { desc => $attrs->{Rule_description}, format => $attrs->{Rule_format}, }; } sub register_action { my $self = shift; my ( $name, $obj ) = @_; croak "Already have a action function called $name" if exists $self->{action}->{$name}; foreach my $method ( "parse_action_$name", "deparse_action_$name", "eval_action_$name" ) { eval { $obj->can( $method ) } or croak "Expected that $obj can $method"; } $self->{action}->{$name} = { obj => $obj }; } sub list_actions { my $self = shift; return ( keys %{ $self->{action} } ), ( $self->{parent} ? $self->{parent}->list_actions : () ); } sub get_action { my $self = shift; my ( $name ) = @_; return $self->{action}->{$name} if $self->{action}->{$name}; return $self->{parent}->get_action( $name ) if $self->{parent}; die "No such action '$name'\n"; } sub parse_action { my $self = shift; # my ( $spec ) = @_ but we'll use $_[0] for alias $_[0] =~ s/^(\w+)\s*// or die "Expected an action name, found '$_[0]'\n"; my $actionname = $1; my $action = $self->get_action( $actionname ); my $actionspec; if( $_[0] =~ m/^\(/ ) { $actionspec = extract_bracketed( $_[0], q{("')} ); defined $actionspec or die "Bad argument spec '$actionspec' for action $actionname\n"; s/^\(\s*//, s/\s*\)$// for $actionspec; } my $method = "parse_action_$actionname"; my @actionargs = eval { $action->{obj}->$method( $actionspec ) }; if( $@ ) { my $err = $@; chomp $err; die "$err while parsing condition spec '$actionspec' for $actionname\n"; } return [ $actionname, @actionargs ]; } sub deparse_action { my $self = shift; my ( $actionref ) = @_; my ( $name, @args ) = @$actionref; my $action = $self->get_action( $name ); my $method = "deparse_action_$name"; my $argspec = $action->{obj}->$method( @args ); return defined $argspec ? "$name($argspec)" : $name; } sub eval_action { my $self = shift; my ( $actionref, $event, $results ) = @_; my ( $name, @args ) = @$actionref; my $action = $self->get_action( $name ); my $method = "eval_action_$name"; return $action->{obj}->$method( $event, $results, @args ); } sub describe_action { my $self = shift; my ( $name ) = @_; my $action = $self->get_action( $name ); my $attrs = get_subattrs( $action->{obj}->can( "parse_action_$name" ) ); return { desc => $attrs->{Rule_description}, format => $attrs->{Rule_format}, }; } sub new_chain { my $self = shift; my ( $name ) = @_; $self->{chains}->{$name} ||= Circle::Rule::Chain->new( $self ); } sub chains { my $self = shift; return keys %{ $self->{chains} }; } sub get_chain { my $self = shift; my ( $chainname ) = @_; return $self->{chains}->{$chainname} || die "No such rulechain called $chainname\n"; } sub run { my $self = shift; my ( $chainname, $event ) = @_; my $chain = $self->{chains}->{$chainname} or die "No such rulechain called $chainname\n"; $chain->run( $event ); } # Internal rules for boolean logic sub parse_cond_not : Rule_description("Invert the sense of a sub-condition") : Rule_format('condition') { my $self = shift; my ( $spec ) = @_; return $self->parse_cond( $spec ); } sub deparse_cond_not { my $self = shift; my ( $cond ) = @_; return $self->deparse_cond( $cond ); } sub eval_cond_not { my $self = shift; my ( $event, $results, $cond ) = @_; # Construct a new result set which we throw away return not $self->eval_cond( $cond, $event, Circle::Rule::Resultset->new() ); } sub parse_cond_any : Rule_description("Check if any sub-condition is true") : Rule_format('condition ...') { my $self = shift; my ( $spec ) = @_; my @conds; while( length $spec ) { push @conds, $self->parse_cond( $spec ); $spec =~ s/\s+//; # trim ws } @conds or die "Expected at least one condition\n"; return @conds; } sub deparse_cond_any { my $self = shift; my ( @conds ) = @_; return join( " ", map { $self->deparse_cond( $_ ) } @conds ); } sub eval_cond_any { my $self = shift; my ( $event, $results, @conds ) = @_; foreach my $cond ( @conds ) { return 1 if $self->eval_cond( $cond, $event, $results ); } return 0; } sub parse_cond_all : Rule_description("Check if all sub-conditions are true") : Rule_format('condition ...') { my $self = shift; my ( $spec ) = @_; my @conds; while( length $spec ) { push @conds, $self->parse_cond( $spec ); $spec =~ s/\s+//; # trim ws } @conds or die "Expected at least one condition\n"; return @conds; } sub deparse_cond_all { my $self = shift; my ( @conds ) = @_; return join( " ", map { $self->deparse_cond( $_ ) } @conds ); } sub eval_cond_all { my $self = shift; my ( $event, $results, @conds ) = @_; # Construct sub-results because we don't want any results to apply if a # later failure causes us to fail after an earlier cond was successful and # stored results my $subresults = Circle::Rule::Resultset->new(); foreach my $cond ( @conds ) { return 0 unless $self->eval_cond( $cond, $event, $subresults ); } $results->merge_from( $subresults ); return 1; } 0x55AA; circle-be-0.173320/lib/Circle/Session000755001750001750 013207602007 15706 5ustar00leoleo000000000000circle-be-0.173320/lib/Circle/Session/Tabbed.pm000444001750001750 2160613207602007 17607 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk package Circle::Session::Tabbed; use strict; use base qw( Tangence::Object Circle::Commandable Circle::Configurable ); use Carp; our $VERSION = '0.173320'; sub _session_type { my ( $opts ) = @_; keys %$opts or return __PACKAGE__; print STDERR "Need Tabbed FE session for extra options:\n"; print STDERR " ".join( "|", sort keys %$opts )."\n"; return undef; } sub new { my $class = shift; my %args = @_; my $self = $class->SUPER::new( %args ); $self->{root} = $args{root}; $self->{identity} = $args{identity}; # Start with just the root object in first tab $self->set_prop_tabs( [ $args{root} ] ); $self->{items} = {}; return $self; } sub items { my $self = shift; return @{ $self->get_prop_tabs }; } sub describe { my $self = shift; return __PACKAGE__."[$self->{identity}]"; } sub _item_to_index { my $self = shift; my ( $item ) = @_; my @items = $self->items; $items[$_] == $item and return $_ for 0 .. $#items; return undef; } sub show_item { my $self = shift; my ( $item ) = @_; return if grep { $_ == $item } $self->items; $self->push_prop_tabs( $item ); } sub unshow_item { my $self = shift; my ( $item ) = @_; my $index; if( ref $item ) { $index = $self->_item_to_index( $item ); return unless defined $index; } else { $index = $item; } $self->splice_prop_tabs( $index, 1, () ); } sub new_item { my $self = shift; my ( $item ) = @_; # Did we know about it? return if exists $self->{items}->{$item}; $self->{items}->{$item} = 1; $self->show_item( $item ); } sub delete_item { my $self = shift; my ( $item ) = @_; delete $self->{items}->{$item}; $self->unshow_item( $item ); } sub clonefrom { my $self = shift; my ( $src ) = @_; my @srcitems = $src->items; foreach my $index ( 0 .. $#srcitems ) { my $item = $srcitems[$index]; my $curindex = $self->_item_to_index( $item ); if( !defined $curindex ) { $self->splice_prop_tabs( $index, 0, $item ); } elsif( $curindex != $index ) { $self->move_prop_tabs( $curindex, $index - $curindex ); } } $self->splice_prop_tabs( scalar @srcitems, scalar $self->items - scalar @srcitems, () ); } sub _get_item { my $self = shift; my ( $path, $curitem, $create ) = @_; $curitem or $path =~ m{^/} or croak "Cannot walk a relative path without a start item"; $curitem = $self->{root} if $path =~ s{^/}{}; foreach ( split( m{/}, $path ) ) { next unless length $_; # skip empty path elements my $nextitem; if( $curitem->can( "get_item" ) ) { $nextitem = $curitem->get_item( $_, $create ); } elsif( $curitem->can( "enumerate_items" ) ) { $nextitem = $curitem->enumerate_items->{$_}; } else { die "@{[ $curitem->describe ]} has no child items\n"; } defined $nextitem or die "@{[ $curitem->describe ]} has no child item called $_\n"; $curitem = $nextitem; } return $curitem; } sub _cat_path { my ( $p, $q ) = @_; return $q if $p eq ""; return "/$q" if $p eq "/"; return "$p/$q"; } sub load_configuration { my $self = shift; my ( $ynode ) = @_; $self->set_prop_tabs( [] ); foreach my $tab ( @{ $ynode->{tabs} } ) { my $item = $self->_get_item( $tab, $self->{root}, 1 ); $self->push_prop_tabs( $item ); } } sub store_configuration { my $self = shift; my ( $ynode ) = @_; $ynode->{tabs} = [ map { my $item = $_; my @components; while( $item ) { unshift @components, $item->enumerable_name; $item = $item->parent; } join "/", @components; } $self->items ]; } sub command_list : Command_description("List showable window items") : Command_arg('path?') : Command_opt('all=+', desc => "list all the items") { my $self = shift; my ( $itempath, $opts, $cinv ) = @_; my @items; if( $opts->{all} ) { @items = ( [ "/" => $self->{root} ] ); } else { @items = ( [ "" => $cinv->invocant ] ); } if( defined $itempath ) { if( $itempath =~ m{^/} ) { $items[0]->[0] = $itempath; } else { $items[0]->[0] .= $itempath; } $items[0]->[1] = $self->_get_item( $itempath, $items[0]->[1] ); } $cinv->respond( "The following items exist" . ( defined $itempath ? " from path $itempath" : "" ) ); # Walk a tree without using a recursive function my @table; while( my $i = pop @items ) { my ( $name, $item ) = @$i; push @table, [ " $name", ref($item) ] if length $name; if( my $subitems = $item->can( "enumerate_items" ) && $item->enumerate_items ) { push @items, [ _cat_path( $name, $_ ) => $subitems->{$_} ] for reverse sort keys %$subitems; } } $cinv->respond_table( \@table, colsep => " - " ); return; } sub command_show : Command_description("Show a window item") : Command_arg("path?") : Command_opt("all=+", desc => "show all the non-visible items") { my $self = shift; my ( $itempath, $opts, $cinv ) = @_; my @items; if( $opts->{all} ) { my %visible = map { $_ => 1 } $self->items; my @more = ( $self->{root} ); while( my $item = pop @more ) { push @items, $item if !$visible{$item}; if( my $subitems = $item->can( "enumerate_items" ) && $item->enumerate_items ) { push @more, @{$subitems}{sort keys %$subitems}; } } } elsif( defined $itempath ) { @items = $self->_get_item( $itempath, $cinv->invocant ); } else { $cinv->responderr( "show: require PATH or -all" ); return; } $self->show_item( $_ ) for @items; return; } sub command_hide : Command_description("Hide a window item") { my $self = shift; my ( $cinv ) = @_; my $item = $cinv->invocant; if( $item->isa( "Circle::RootObj" ) ) { $cinv->responderr( "Cannot hide the global tab" ); return; } $self->unshow_item( $item ); return; } sub command_tab : Command_description("Manipulate window item tabs") { } sub command_tab_move : Command_description("Move the tab to elsewhere in the window ordering\n". "POSITION may be an absolute number starting from 1,\n". " a relative number with a leading + or -,\n". " one of first | left | right | last") : Command_subof('tab') : Command_arg('position') { my $self = shift; my ( $position, $cinv ) = @_; my $tabs = $self->get_prop_tabs; my $item = $cinv->invocant; my $index; $tabs->[$_] eq $item and ( $index = $_, last ) for 0 .. $#$tabs; defined $index or return $cinv->responderr( "Cannot find current index of item" ); $position = "+1" if $position eq "right"; $position = "-1" if $position eq "left"; $position = "1" if $position eq "first"; # 1-based $position = @$tabs if $position eq "last"; # 1-based my $delta; if( $position =~ m/^[+-]/ ) { # relative $delta = $position+0; } elsif( $position =~ m/^\d+$/ ) { # absolute; but input from user was 1-based. $position -= 1; $delta = $position - $index; } else { return $cinv->responderr( "Unrecognised position/movement specification: $position" ); } return $cinv->responderr( "Cannot move that far left" ) if $index + $delta < 0; return $cinv->responderr( "Cannot move that far right" ) if $index + $delta > $#$tabs; $self->move_prop_tabs( $index, $delta ); return; } sub command_tab_goto : Command_description("Activate a numbered tab\n". "POSITION may be an absolute number starting from 1,\n". " a relative number with a leading + or -,\n". " one of first | left | right | last") : Command_subof('tab') : Command_arg('position') { my $self = shift; my ( $position, $cinv ) = @_; my $tabs = $self->get_prop_tabs; my $item = $cinv->invocant; my $index; $tabs->[$_] eq $item and ( $index = $_, last ) for 0 .. $#$tabs; defined $index or return $cinv->responderr( "Cannot find current index of item" ); $position = "+1" if $position eq "right"; $position = "-1" if $position eq "left"; $position = "1" if $position eq "first"; # 1-based $position = @$tabs if $position eq "last"; # 1-based if( $position =~ m/^[+-]/ ) { # relative $index += $position; } elsif( $position =~ m/^\d+$/ ) { # absolute; but input from user was 1-based. $index = $position - 1; } else { return $cinv->responderr( "Unrecognised position/movement specification: $position" ); } $self->get_prop_tabs->[$index]->fire_event( raise => () ); return; } 0x55AA; circle-be-0.173320/lib/Circle/Widget000755001750001750 013207602007 15506 5ustar00leoleo000000000000circle-be-0.173320/lib/Circle/Widget/Box.pm000444001750001750 161713207602007 16736 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2010 -- leonerd@leonerd.org.uk package Circle::Widget::Box; use strict; use warnings; use base qw( Circle::Widget ); our $VERSION = '0.173320'; use Carp; sub new { my $class = shift; my %args = @_; my $self = $class->SUPER::new( @_ ); $self->set_prop_orientation( $args{orientation} ); return $self; } sub add { my $self = shift; my ( $child, %opts ) = @_; $opts{child} = $child; $self->push_prop_children( \%opts ); } sub add_spacer { my $self = shift; my ( %opts ) = @_; # TODO: For now, only allow one spacer, and it must be in expand mode croak "Already have one spacer, can't add another" if grep { !$_->{child} } @{ $self->get_prop_children }; croak "Spacer must be in expand mode" if !$opts{expand}; $self->push_prop_children( \%opts ); } 0x55AA; circle-be-0.173320/lib/Circle/Widget/Entry.pm000444001750001750 377613207602007 17317 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2013 -- leonerd@leonerd.org.uk package Circle::Widget::Entry; use strict; use warnings; use base qw( Circle::Widget ); our $VERSION = '0.173320'; sub new { my $class = shift; my %args = @_; my $self = $class->SUPER::new( @_ ); $self->{on_enter} = $args{on_enter}; $self->{history} = $args{history}; $self->set_prop_text( "" ); $self->set_prop_autoclear( $args{autoclear} ); return $self; } sub method_enter { my $self = shift; my ( $ctx, $text ) = @_; $self->{on_enter}->( $text, $ctx ); if( defined( my $history = $self->{history} ) ) { my $histqueue = $self->get_prop_history; my $overcount = @$histqueue + 1 - $history; $self->shift_prop_history( $overcount ) if $overcount > 0; $self->push_prop_history( $text ); } } sub set_on_typing { my $self = shift; my ( $on_typing ) = @_; $self->{on_typing} = $on_typing; $self->set_prop_want_typing( defined $self->{on_typing} ); } sub method_typing { my $self = shift; my ( $ctx, $typing ) = @_; $self->{on_typing}->( $typing ) if $self->{on_typing}; } package Circle::Widget::Entry::CompleteGroup; use base qw( Tangence::Object ); sub new { my $class = shift; my %args = @_; my $self = $class->SUPER::new( @_ ); $self->set_prop_only_at_sol( $args{only_at_sol} || 0 ); $self->set_prop_prefix_sol( $args{prefix_sol} || '' ); $self->set_prop_suffix_sol( $args{suffix_sol} || '' ); return $self; } sub set { my $self = shift; my ( @strings ) = @_; $self->set_prop_items( \@strings ); } sub add { my $self = shift; my ( $str ) = @_; grep { $_ eq $str } @{ $self->get_prop_items } or $self->push_prop_items( $str ); } sub remove { my $self = shift; my ( $str ) = @_; my $items = $self->get_prop_items; my @indices = grep { $items->[$_] eq $str } 0 .. $#$items; $self->splice_prop_items( $_, 1, () ) for reverse @indices; } 0x55AA; circle-be-0.173320/lib/Circle/Widget/Label.pm000444001750001750 40013207602007 17172 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2010 -- leonerd@leonerd.org.uk package Circle::Widget::Label; use strict; use warnings; use base qw( Circle::Widget ); our $VERSION = '0.173320'; 0x55AA; circle-be-0.173320/lib/Circle/Widget/Scroller.pm000444001750001750 134313207602007 17767 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk package Circle::Widget::Scroller; use strict; use warnings; use base qw( Circle::Widget ); our $VERSION = '0.173320'; sub new { my $class = shift; my %args = @_; my $self = $class->SUPER::new( @_ ); $self->{scrollback} = $args{scrollback}; return $self; } sub push_event { my $self = shift; my ( $event, $time, $args ) = @_; my $eventqueue = $self->get_prop_displayevents; my $overcount = @$eventqueue + 1 - $self->{scrollback}; $self->shift_prop_displayevents( $overcount ) if $overcount > 0; $self->push_prop_displayevents( [ $event, $time, $args ] ); } 0x55AA; circle-be-0.173320/share000755001750001750 013207602007 13416 5ustar00leoleo000000000000circle-be-0.173320/share/circle.tan000444001750001750 475713207602007 15535 0ustar00leoleo000000000000class Circle.Commandable { method do_command(str); } class Circle.WindowItem { isa Circle.Commandable; event raise(); method reset_level(); method get_widget() -> obj; smashed prop tag = str; smashed prop level = int; } class Circle.RootObj { isa Circle.WindowItem; method get_session(list(str)) -> obj; event network_added(obj); prop networks = hash of obj; } class Circle.Session.Tabbed { prop tabs = array of obj; event raise_item(obj); } class Circle.Net.IRC { isa Circle.WindowItem; method get_isupport(str) -> any; event connected(); event disconnected(); prop nick = str; prop away = bool; prop channels = objset of obj; prop users = objset of obj; } class Circle.Net.IRC.Target { isa Circle.WindowItem; method msg(str); method notice(str); method act(str); event msg(str,str); event notice(str,str); event act(str, str); smashed prop name = str; smashed prop net = obj; smashed prop real = bool; } class Circle.Net.IRC.User { isa Circle.Net.IRC.Target; event change_nick(str,str,str,str); prop ident = str; prop presence = str; } class Circle.Net.IRC.Channel { isa Circle.Net.IRC.Target; method mode(str,list(str)); method topic(str); event self_joined(); event self_parted(); event join(str); event part(str,str); event kick(str,str,str); event topic(str,str); prop topic = str; prop occupants = hash of dict(any); prop occupant_summary = hash of int; prop my_flag = str; prop mode = hash of str; prop modestr = str; } class Circle.Net.Raw { isa Circle.WindowItem; event connected(str,int); event disconnected(); prop connected = bool; } class Circle.Widget { smashed prop classes = array of str; smashed prop focussed = bool; } class Circle.Widget.Box { isa Circle.Widget; smashed prop orientation = str; # TODO: enumeration smashed prop children = array of dict(any); } class Circle.Widget.Entry { isa Circle.Widget; method enter(str); smashed prop autoclear = bool; prop text = str; prop history = queue of str; prop completions = objset of obj; smashed prop want_typing = bool; method typing(bool); } class Circle.Widget.Entry.CompleteGroup { smashed prop only_at_sol = bool; smashed prop prefix_sol = str; smashed prop suffix_sol = str; smashed prop items = array of str; } class Circle.Widget.Label { isa Circle.Widget; prop text = str; } class Circle.Widget.Scroller { isa Circle.Widget; prop displayevents = queue of list(any); } circle-be-0.173320/t000755001750001750 013207602007 12557 5ustar00leoleo000000000000circle-be-0.173320/t/00use.t000444001750001750 152513207602007 14040 0ustar00leoleo000000000000use strict; use warnings; use Test::More tests => 24; use_ok( "Circle" ); use_ok( "Circle::Command" ); use_ok( "Circle::CommandInvocation" ); use_ok( "Circle::Commandable" ); use_ok( "Circle::Configurable" ); use_ok( "Circle::GlobalRules" ); use_ok( "Circle::RootObj" ); use_ok( "Circle::Rule::Chain" ); use_ok( "Circle::Rule::Resultset" ); use_ok( "Circle::Rule::Store" ); use_ok( "Circle::Ruleable" ); use_ok( "Circle::Session::Tabbed" ); use_ok( "Circle::TaggedString" ); use_ok( "Circle::Widget" ); use_ok( "Circle::Widget::Box" ); use_ok( "Circle::Widget::Entry" ); use_ok( "Circle::Widget::Label" ); use_ok( "Circle::Widget::Scroller" ); use_ok( "Circle::WindowItem" ); use_ok( "Circle::Net::IRC" ); use_ok( "Circle::Net::IRC::Target" ); use_ok( "Circle::Net::IRC::Channel" ); use_ok( "Circle::Net::IRC::User" ); use_ok( "Circle::Net::Raw" ); circle-be-0.173320/t/01rootobj.t000444001750001750 403413207602007 14721 0ustar00leoleo000000000000use strict; use warnings; use Test::More tests => 13; use IO::Async::Test; use IO::Async::Loop; use Circle; use t::CircleTest qw( get_widget_from get_widgetset_from ); my $loop = IO::Async::Loop->new; testing_loop( $loop ); my ( $circle, $client ) = Circle->new_with_client( loop => $loop ); my $rootobj; wait_for { $rootobj = $client->rootobj }; isa_ok( $rootobj, "Tangence::ObjectProxy", '$rootobj' ); ok( $rootobj->proxy_isa( "Circle.RootObj" ), '$rootobj proxy isa Circle.RootObj' ); ok( $rootobj->proxy_isa( "Circle.WindowItem" ), '$rootobj proxy isa Circle.WindowItem' ); my $global_widget = get_widget_from $rootobj; ok( $global_widget->proxy_isa( "Circle.Widget" ), '$global_widget' ); # Don't rely too much on exact UI layout; build a map of class->widget instead my $widgets = get_widgetset_from $rootobj; ok( my $scroller = $widgets->{"Circle.Widget.Scroller"}, 'Found a Scroller widget' ); ok( my $entry = $widgets->{"Circle.Widget.Entry"}, 'Found an Entry widget' ); my $displayevents; $scroller->watch_property( "displayevents", on_updated => sub { $displayevents = $_[0] }, )->get; my $time_before = time; $entry->call_method( enter => "/eval 1" )->get; wait_for { $displayevents }; my $time_after = time; is( scalar @$displayevents, 1, '$displayevents after entering command contains one line' ); my ( $event ) = @$displayevents; is( $event->[0], "response", '$event name' ); # Can't quite be sure of the timestamp but it'll be bounded ok( $time_before >= $event->[1] && $event->[1] >= $time_after, '$event time' ); is_deeply( $event->[2], { text => "Result: 1" }, '$event args' ); undef $displayevents; $rootobj->call_method( do_command => "eval 1" )->get; wait_for { $displayevents }; ( $event ) = @$displayevents; is( $event->[0], "response", '$event name from do_command' ); # Can't quite be sure of the timestamp but it'll be bounded ok( $time_before >= $event->[1] && $event->[1] >= $time_after, '$event time from do_command' ); is_deeply( $event->[2], { text => "Result: 1" }, '$event args from do_command' ); circle-be-0.173320/t/02session.t000444001750001750 176213207602007 14734 0ustar00leoleo000000000000use strict; use warnings; use Test::More tests => 5; use Test::Identity; use IO::Async::Test; use IO::Async::Loop; use Circle; use t::CircleTest qw( get_session send_command ); my $loop = IO::Async::Loop->new; testing_loop( $loop ); my ( $circle, $client ) = Circle->new_with_client( loop => $loop ); my $rootobj; wait_for { $rootobj = $client->rootobj }; my $session = get_session $rootobj; ok( $session->proxy_isa( "Circle.Session.Tabbed" ), '$session proxy isa Circle.Session.Tabbed' ); my $tabs; $session->watch_property_with_initial( "tabs", on_updated => sub { $tabs = $_[0] }, )->get; wait_for { $tabs }; is( scalar @$tabs, 1, '$tabs contains 1 item' ); identical( $tabs->[0], $rootobj, '$tabs->[0] is RootObj' ); undef $tabs; send_command $rootobj, "networks add -type raw Test"; wait_for { $tabs }; is( scalar @$tabs, 2, '$tabs contains 2 items after /networks add' ); my $rawnet = $tabs->[1]; ok( $rawnet->proxy_isa( "Circle.Net.Raw" ), '$tabs->[1] proxy isa Circle.Net.Raw' ); circle-be-0.173320/t/50net-raw.t000444001750001750 634013207602007 14626 0ustar00leoleo000000000000use strict; use warnings; use Test::More tests => 10; use IO::Async::Test; use IO::Async::Loop; use IO::Async::Listener; use Circle; use t::CircleTest qw( send_command get_session get_widgetset_from ); my $loop = IO::Async::Loop->new; testing_loop( $loop ); my ( $circle, $client ) = Circle->new_with_client( loop => $loop ); my $rootobj; wait_for { $rootobj = $client->rootobj }; my $session = get_session $rootobj; send_command $rootobj, "networks add -type raw Test"; my ($rawnet) = $session->get_property( "tabs", )->get->[1]; defined $rawnet or die "Expected a tab [1] didn't get one"; ok( $rawnet->proxy_isa( "Circle.Net.Raw" ), '$rawnet proxy isa Circle.Net.Raw' ); my $connected_args; $rawnet->subscribe_event( "connected", on_fire => sub { $connected_args = [ @_ ] }, )->get; my $widgets = get_widgetset_from $rawnet; my $serverstream; my $listener = IO::Async::Listener->new( on_stream => sub { ( undef, $serverstream ) = @_; }, ); $loop->add( $listener ); $listener->listen( addr => { family => "inet", socktype => "stream", ip => "127.0.0.1", port => 0, }, on_listen_error => sub { die "Test failed early - listen $_[-1]\n" }, ); my $port = $listener->read_handle->sockport; send_command $rawnet, "connect localhost $port"; wait_for { defined $serverstream }; ok( 1, '$rawnet connected to listener' ); wait_for { $connected_args }; ok( 1, '$rawnet fires connected event' ); is( $connected_args->[0], "localhost", 'connected event host' ); is( $connected_args->[1], $port, 'connected event port' ); my @lines_from_client; $serverstream->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; push @lines_from_client, $1 while $$buffref =~ s/(.*?)\r?\n//; return 0; } ); $loop->add( $serverstream ); $widgets->{"Circle.Widget.Entry"}->call_method( enter => "Hello, server!" )->get; wait_for { @lines_from_client }; is( shift @lines_from_client, "Hello, server!", 'client can send to server' ); my @displayevents; $widgets->{"Circle.Widget.Scroller"}->watch_property( "displayevents", on_set => sub {}, on_push => sub { push @displayevents, @_; }, on_shift => sub {}, )->get; my $time_before = time; $serverstream->write( "Hello, client!\r\n" ); wait_for { @displayevents }; my $time_after = time; my $event = shift @displayevents; is( $event->[0], "text", '$event name for server reply' ); # Can't quite be sure of the timestamp but it'll be bounded ok( $time_before >= $event->[1] && $event->[1] >= $time_after, '$event time for server reply' ); is_deeply( $event->[2], { text => "Hello, client!" }, '$event args for server reply' ); # Test that the whole lot doesn't fall in a heap and die just because a frontend disappears $client->close; undef $client; # Acknowledge the close of connection $loop->loop_once( 1 ); # Cheating my @events; $circle->{rootobj}->get_prop_networks->{Test}->get_widget_scroller->watch_property( displayevents => on_set => sub { shift; @events = @_ }, on_push => sub { shift; push @events, @_ }, on_shift => sub { shift; splice @events, 0, shift }, ); $serverstream->write( "Another line\r\n" ); wait_for { @events }; ok( 1, "Server didn't die after new event for closed client" ); circle-be-0.173320/t/CircleTest.pm000444001750001750 245113207602007 15315 0ustar00leoleo000000000000# You may distribute under the terms of the GNU General Public License # # (C) Paul Evans, 2012-2013 -- leonerd@leonerd.org.uk package t::CircleTest; use strict; use warnings; our $VERSION = '0.173320'; use Exporter qw( import ); our @EXPORT_OK = qw( get_session get_widget_from get_widgetset_from send_command ); use IO::Async::Test; sub get_session { my ( $rootobj ) = @_; my ($session) = $rootobj->call_method( get_session => [qw( tabs )] )->get; return $session; } sub get_widget_from { my ( $windowitem ) = @_; my ($widget) = $windowitem->call_method( 'get_widget' )->get; return $widget; } my %widgetsets; sub get_widgetset_from { my ( $windowitem ) = @_; return $widgetsets{$windowitem} if $widgetsets{$windowitem}; my $widget = get_widget_from( $windowitem ); my %widgets; my @queue = ( $widget ); while( my $w = shift @queue ) { if( $w->proxy_isa( "Circle.Widget.Box" ) ) { push @queue, map { $_->{child} } @{ $w->prop( "children" ) }; } else { $widgets{ ( $w->proxy_isa )[0]->name } = $w; } } return $widgetsets{$windowitem} = \%widgets; } sub send_command { my ( $windowitem, $command ) = @_; $windowitem->call_method( do_command => $command, )->get; } 0x55AA;