App-KGB-1.31000755001750001750 012203520733 11241 5ustar00damdam000000000000App-KGB-1.31/MANIFEST000444001750001750 240412203520733 12527 0ustar00damdam000000000000Build.PL Changes eg/kgb-client.conf.sample eg/post-commit eg/run-test-bot-1 eg/run-test-bot-2 eg/run-test-bot-dump eg/setup-test-git-env.sh eg/simple-soap-client eg/simple-soap-server eg/test-client.conf eg/test-server-1.conf eg/test-server-1.conf.d/repos.conf eg/test-server-2.conf etc/kgb.conf HOWTO.release lib/App/KGB.pm lib/App/KGB/API.pm lib/App/KGB/Change.pm lib/App/KGB/Client.pm lib/App/KGB/Client/CVS.pm lib/App/KGB/Client/Fake.pm lib/App/KGB/Client/Git.pm lib/App/KGB/Client/RelayMsg.pm lib/App/KGB/Client/ServerRef.pm lib/App/KGB/Client/Subversion.pm lib/App/KGB/Commit.pm lib/App/KGB/Commit/Tag.pm lib/App/KGB/Painter.pm lib/JSON/RPC/Client/Any.pm lib/WWW/Shorten/Debli.pm LICENSE Makefile man5/kgb-client.conf.pod man5/kgb.conf.pod man7/kgb-protocol.pod MANIFEST This list of files MANIFEST.SKIP META.json META.yml privinc/My/Builder.pm script/kgb-add-project script/kgb-bot script/kgb-client script/kgb-split-config t/00-compile.t t/00-compile_scripts.t t/00-compile_shell_scripts.t t/30-bot-changes.t t/50-client.t t/51-client_branch_module.t t/52-client-git.t t/53-client-git-merges.t t/54-client-git-squash.t t/55-client-git-merges-ff.t t/56-client-git-ff-merge-2.t t/57-client-git-squash-tags.t t/critic.t t/perlcriticrc t/pod-coverage.t t/pod.t t/version.t TODO App-KGB-1.31/Build.PL000444001750001750 535712203520733 12704 0ustar00damdam000000000000package main; use strict; use warnings; use lib qw(privinc); use My::Builder; use utf8; my $json_rpc_client_module = eval { require JSON::RPC::Client } ? 'JSON::RPC::Client' : 'JSON::RPC::Legacy::Client'; my $builder = My::Builder->new( dist_name => 'App-KGB', dist_version_from => 'lib/App/KGB.pm', dist_author => [ "Martín Ferrari", "Damyan Ivanov", "gregor herrmann" ], license => 'gpl2', create_license => 1, configure_requires => { 'Module::Build' => '0.40', perl => '5.010', }, test_requires => { autodie => 0, 'Git' => 0, perl => '5.010', 'SVN::Core' => 0, 'SVN::Fs' => 0, 'SVN::Repos' => 0, 'Test::Compile' => 0, 'Test::Perl::Critic' => 0, 'Test::Pod::Coverage' => 0, 'Test::Pod' => 0, 'Test::Simple' => '0.92', 'YAML' => 0, }, requires => { perl => '5.010', 'Class::Accessor' => 0, 'Digest::SHA' => 0, 'DirHandle' => 0, 'File::Touch' => 0, 'Git' => 0, 'IPC::Run' => 0, 'IPC::System::Simple' => 0, 'JSON::XS' => 0, $json_rpc_client_module => 0, 'POE' => 0, 'POE::Component::IRC' => '5.56', 'POE::Component::Server::SOAP' => 0, 'Proc::PID::File' => 0, 'SOAP::Lite' => 0, 'SVN::Core' => 0, 'SVN::Fs' => 0, 'SVN::Repos' => 0, 'Schedule::RateLimiter' => 0, 'Time::Piece' => 0, 'WWW::Shorten' => 0, 'YAML' => 0, }, bindoc_dirs => [qw(script sbin)], install_path => { sbin => '/usr/sbin', etc => 'etc' }, sbin_files => { 'script/kgb-bot' => 'sbin/kgb-bot', 'script/kgb-add-project' => 'sbin/kgb-add-project', 'script/kgb-split-config' => 'sbin/kgb-split-config', }, etc_files => { 'etc/kgb.conf' => 'etc/kgb-bot/kgb.conf' }, man_files => { 'man5/*' => 'man5/' }, script_files => [ 'script/kgb-client' ], no_index => { directory => [ 'privinc' ], }, ); $builder->add_build_element('sbin'); $builder->add_build_element('etc'); $builder->add_build_element('man'); $builder->create_build_script(); App-KGB-1.31/META.json000444001750001750 724512203520733 13027 0ustar00damdam000000000000{ "abstract" : "collaborative IRC helper", "author" : [ "Martín Ferrari", "Damyan Ivanov", "gregor herrmann" ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4007, CPAN::Meta::Converter version 2.132140", "license" : [ "open_source" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "App-KGB", "no_index" : { "directory" : [ "privinc" ] }, "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0.40", "perl" : "5.010" } }, "runtime" : { "requires" : { "Class::Accessor" : "0", "Digest::SHA" : "0", "DirHandle" : "0", "File::Touch" : "0", "Git" : "0", "IPC::Run" : "0", "IPC::System::Simple" : "0", "JSON::RPC::Legacy::Client" : "0", "JSON::XS" : "0", "POE" : "0", "POE::Component::IRC" : "5.56", "POE::Component::Server::SOAP" : "0", "Proc::PID::File" : "0", "SOAP::Lite" : "0", "SVN::Core" : "0", "SVN::Fs" : "0", "SVN::Repos" : "0", "Schedule::RateLimiter" : "0", "Time::Piece" : "0", "WWW::Shorten" : "0", "YAML" : "0", "perl" : "5.010" } } }, "provides" : { "App::KGB" : { "file" : "lib/App/KGB.pm", "version" : "1.31" }, "App::KGB::API" : { "file" : "lib/App/KGB/API.pm", "version" : "4" }, "App::KGB::Change" : { "file" : "lib/App/KGB/Change.pm", "version" : "1.22" }, "App::KGB::Client" : { "file" : "lib/App/KGB/Client.pm", "version" : "1.28" }, "App::KGB::Client::CVS" : { "file" : "lib/App/KGB/Client/CVS.pm", "version" : "1.23" }, "App::KGB::Client::Fake" : { "file" : "lib/App/KGB/Client/Fake.pm", "version" : "1.17" }, "App::KGB::Client::Git" : { "file" : "lib/App/KGB/Client/Git.pm", "version" : "1.28" }, "App::KGB::Client::RelayMsg" : { "file" : "lib/App/KGB/Client/RelayMsg.pm", "version" : "1.27" }, "App::KGB::Client::ServerRef" : { "file" : "lib/App/KGB/Client/ServerRef.pm", "version" : "1.28" }, "App::KGB::Client::Subversion" : { "file" : "lib/App/KGB/Client/Subversion.pm", "version" : "1.27" }, "App::KGB::Commit" : { "file" : "lib/App/KGB/Commit.pm", "version" : "1.27" }, "App::KGB::Commit::Tag" : { "file" : "lib/App/KGB/Commit/Tag.pm", "version" : "1.28" }, "App::KGB::Painter" : { "file" : "lib/App/KGB/Painter.pm", "version" : "1.27" }, "JSON::RPC::Client::Any" : { "file" : "lib/JSON/RPC/Client/Any.pm", "version" : "1.28" }, "WWW::Shorten::Debli" : { "file" : "lib/WWW/Shorten/Debli.pm", "version" : "0.1" } }, "release_status" : "stable", "resources" : { "license" : [ "http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt" ] }, "version" : "1.31", "x_test_requires" : { "Git" : "0", "SVN::Core" : "0", "SVN::Fs" : "0", "SVN::Repos" : "0", "Test::Compile" : "0", "Test::Perl::Critic" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Simple" : "0.92", "YAML" : "0", "autodie" : "0", "perl" : "5.010" } } App-KGB-1.31/Makefile000444001750001750 64512203520733 13023 0ustar00damdam000000000000#!/usr/bin/make -f PERL ?= /usr/bin/perl Build: Build.PL $(PERL) $< all: build build install test manifest distcheck: Build ./Build $@ orig: distclean [ ! -e debian/rules ] || $(MAKE) -f debian/rules clean $(MAKE) Build ./Build $@ dist: manifest distcheck ./Build $@ clean: [ ! -e Build ] || ./Build $@ realclean distclean: [ ! -e Build ] || ./Build $@ rm -f MANIFEST.bak App-KGB-*.*.tar.gz # vim: noet App-KGB-1.31/LICENSE000444001750001750 4354212203520733 12433 0ustar00damdam000000000000This software is Copyright (c) 2013 by Martn Ferrari & Damyan Ivanov & gregor herrmann. This is free software, licensed under: The GNU General Public License, Version 2, June 1991 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU 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. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), 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 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 show them these terms so they know 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. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. 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 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 derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 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 License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. 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. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary 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 License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 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 Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing 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 for copying, distributing or modifying the Program or works based on it. 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. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. 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 this 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 this License, you may choose any version ever published by the Free Software Foundation. 10. 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 11. 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. 12. 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 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 the public, 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) 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 2 of the License, 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) year 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 is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. App-KGB-1.31/HOWTO.release000444001750001750 70312203520733 13620 0ustar00damdam000000000000Steps for creating new releases =============================== * Bump version in lib/App/KGB.pm and script/kgb-bot * Update Changes and debian/changelog (git-dch) * `make distcheck`, update MANIFEST{,SKIP} as needed. * `make dist' * build/upload for Debian + make orig to get a .orig.tar file. * upload to alioth + https://alioth.debian.org/frs/admin/qrs.php?group_id=100408 * upload to CPAN + cpan-upload -u USERID App-KGB-*.tar.gz App-KGB-1.31/Changes000444001750001750 3667312203520733 12730 0ustar00damdam0000000000001.30 (2013-08-09) * bot: fix colorize_change_wrapper 1.29 (2013-08-08) * add versions to all modules * ensure strict and warnings are used everywhere 1.28 (2013-08-08) [ gregor herrmann ] * client: Fix failure with Safe-2.35. Thanks to Petr Písař for the patch. [ Damyan Ivanov ] * client: detect UTF8 in full author name * git client: add kgb.enable-branch-ff-notification Git option (true by default) for managing fast forward notifications * declare test dependencies in test_requires * client: add --debug option * git client: chomp git-config-determined config file path before usage * replace ~~ (smartmatch) usage. ~~ is deprecated in perl 5.18 * replace given/when usage, declared experimental in perl 5.18 * client: verify config file structures * git client: do not die on unknown ref updates (see #706375) * git client: squash creation if numerous tags (>5 currently) * git client: configurable tag squash threshold/message * client: correct POD about Client->format_message arguments * bot: allow setting of "" color to disable colouring of a given item * bot: use App::KGB::Painter for coloring * bot: add --simulate-color option enabling color codes in the dump file * git client: include tag name in the Tag object created from annotated tags * git client: allow specifying project-id via git-config * t/50-client.t: skip tests with UTF-8 commit messages (subversion) unless C_TYPE is known to use UTF-8. RT#80664 * adapt to newer JSON-RPC which renamed the client module (RT#80666) 1.27 (2013-05-29) * client: + --repository option is no longer required + add support for entirely client-constructed notifications + verbose complaint when a message cannot be encoded as JSON + add support for batching messages + Git: include author name in commit information (Debian: #700319) + Git: add support for configuring some settings via git-config + Git: implement commit squashing for large branch updates * bot: + support miltiple relay messages per request + properly handle multi-line relayed messages + add rate limit support to JSON message relay implementation + Fix a problem where authentication was sent too late, due to throttling caused by JOIN commands sent earlier. This change uses the AutoJoin plugin that knows how to interact with NickServID properly. Patch contributed by poco-irc maintainer, Hinrik Orn Sigurdsson. * both: + add support for ${project} substitution in web_link + documentation improvements * building + Add Time::Piece and IPC::Run to Build.PL. + Build.PL: create LICENSE file during `make dist'. 1.26 (2013-03-28) * update kgb-client.conf manual with the new options * rework Git branch walking avoids multiple notification about merged commits (Closes Debian bug #698133) * notify even if log message is invalid UTF-8 notification with log of "(log is invalid UTF-8)" is better than no notification at all (Closes Debian bug #691183) 1.25 (2012-12-27) * Documentation + client/CVS: mention that CVSROOT is a module + add HOWTO.release to MANIFEST * Internal: + Client/Git: rename _process_commit method to _process_changeset to better describe what it does * Client/Server: + add support for using IRC notices + add support for disabling color * Client: + fix --password option definition + rework configuration to make priority explicit 1.24 (2012-11-22) * Documentation: + Document KGB protocol (currently v4 JSON only). + kgb-client.conf(5): add single-line-commit option. + Document web-link configuration via git-config. * Client: + Add a few checks on the configuration file. + Add --man and --help command-line options. + Fix validation of --single-line-commits argument. + Support web-link option via git configuration. * Server: + Avoid responding to senders having .bot. in their hostname. + change default port to 5391. Closes Debian bug #691562 -- port conflict with approx. + kgb-add-project: chown/chmod config (snippet) like kgb.conf. + Use asterisk for web link separator (used also for commit message separator). + Explicitly check and die if included conf file doesn't exist. + Put URL on first line of multi-line notifications. + Put back SVN in requirements now that Module::Build is fixed. See https://rt.cpan.org/Public/Bug/Display.html?id=59593 1.23 (2012-10-20) * t/compile*: use Test::Compile::Internal in order to show verbose errors * Server: + add --debug command line switch + replace --config-dir option with 'include:' configuration item add 'include: "/etc/kgb-bot/kgb.conf.d"' to the default config + default pid_dir to /var/run/kgb-bot * Documentation: + add manuals for kgb.conf and kgb-client.conf + pod.t: test documentation in man*/ too + give example for gitweb URL * Client: + show expanded web-link in verbose mode + dump processed configuration in verbose mode + shorten_url: really return plain URL if shortening is not enabled + send_changes: detailed dump in verbose mode + introduce module-and-branch-re setting and deprecate branch-and-module-re-swap 1.22 (2012-10-14) * kgb-add-project: document the new --dir option * Add API documentation (JSON-RPC only) * Server: + prepend all IRC strings with a hidden character to avoid addressing + honour --foreground when reloading and don't reopen the log + change the delimiters around web links to make konsole users' life easier + pass --config-dir too on restart + add new kgb-split-config script + refuse to load world-readable configuration files * fix a bug in determining the longest common directory in a change set 1.21 (2012-10-11) * Server: + fix exception handling + better error messages * Debli: prepend 'http://deb.li/' to the returned key 1.20 (2012-10-11) * kgb-add-project: avoid using 'keys($hashref)' which requires too recent perl * Client: + add --reposotory to synopsis + fix --repository in CVS example + CVS: silence debugging output + WWW:Shorten::Debli implementation (uses deb.li for URL shortening) + determine default repository type from the environment (makes --repository useless) + determine default module from git directory (makes --module redundant for Git) + allow explicit protocol configuration + saving of last contacted server -- in a separate method * Server: + ensure trailing \n in KGB->out + note repository id on internal errors + conf.d/*.conf style configuration + use exceptions for handling argument errors + turn on utf8 mode on STDOUT/ERR + use shorter timestamp representation * Both: + protocol 4 (JSON-RPC) + plain message relaying (Closes: #689641) * some spellchecking 1.19 (2012-10-05) * Bot: + add timestamp to log messages + use KGB->out() instead of plain warn() for consistent log messages + tighten auto-responce rate-limit to stop storms in the first screen + silently ignore empty changes + do not crash on internal errors while processing requests * kgb-add-project: sort the channel hashes to make sure "name" is the first key. 1.18 (2012-10-05) * bot: fix channel-must-have-a-repository check for broadcast channels 1.17 (2012-10-05) * improve wording of web-link description * 50-client.t: support keeping temporary directory * declare POD encoding * additional documentation for web-link * explain status-dir in the sample client config * add support for URL shortening via WWW::Shorten + kgb-client: add libwww-shorten-perl to Recommends * client: add --fake option. Fakes a commit to help testing server connection (Closes: #689540) * bot: introduce broadcast channels which receive notifications from all repositories Closes: #688993 + introduce private repositories * bot: fail if a repository has no associated channels * typo/doc fixes * kgb-add-project: add option to save config back to file 1.16 (2012-10-03) * Misc + Typos in documentation fixed * Server + indicate replacement using 'brown' (which should be displayed as low intensity red or something) instead of inverse + add script to add simple projects quickly + call $poe_kernel->has_forked in the child process Makes the reload action of the bot work (Closes: #689018) + reopen logs on reload + create log file in the init script, not in postinst + init script: depend on $network facility and add status option. + init script: add pidfile argument to status option + add bot reload to logrotate configuration * Client + honour 'repository' setting in kgb-client.conf (Closes: 688992) + fix forced single-line commit mode. reported by joeyh, fix by dondelelcaro * Both + Add support for plain web links. No URL shortening yet + Protocol v3 (used by client when extra parameters, e.g. web link need to be sent) + Add CVS support (Closes: #689288) (Mostly in the client, but server needed some changes to drop assumptions that commits always have IDs) 1.15 (2011-09-14) * Client: + make File::Touch usage optional, used only when status_dir is present + use single line note for annotated tags + document --status-dir + consistent POD formatting + POD fix for --single-line-commits in synopsis * Server: + fix single line commits with multi-line explaination + move detect_common_dir to App::KGB::Change (as a class method) + no bold revision by default + drop (bold) repository name from the notification * Misc: + fix eg/run-test-bot-dump + My::Builder: make the 'orig' target also provide a (hardlinked) distribution archive * Tests: + initially trim the dump file only if existing + fix single line notification separator + tags are single line too + add tests for decect_common_dir + more extensive tests for debian/patches series some.patch (still passing) 1.14 (2011-08-24) * Client: + pass the client instance to the server ref + add an option to keep the last used server in a directory * Server: + do not pre-pad $path_string if it is empty + make the message separator colorizable (and leave gray for now) + avoid calling md5_hex with wide characters * Both: + add support for single line commit notifications * Meta: + add MANIFEST and META.yml to MANIFEST (and the distribution) * Misc + provide examples for running two test bots + provide test client configuration + use sample test client config in tests 1.13 (2011-08-13) * bot: add --simulate option * remove dead code * run-test-bot passes arguments to kgb-bot * change the port of the test bot * silence more git jabber during tests * add tests for simulated IRC output 1.12 (2011-08-13) * Updated META.* 1.11 (no public release) * test creation of brand new, orphan branch * fix: no warnings when commits have no author * bot: log repository on authentication failure * put tag name in changes for plain tags too * bot: always decode parameters 1.10 (2011-08-11) [ Daman Ivanov ] * disable indexing of privinc/ * fix a couple of cases of conrdirtional declaration * add a Perl::Critic test for conditional declarations * bot: do not answer back if no answers are configured * rate-lmit autoresponses 1.09 (no official release) [ Damyan Ivanov ] * Skip some tests when required SVN::* or Git modules are unavailable * Fix dist_name from App::KGB to App-KGB 1.08 (2011-08-05) [ Damyan Ivanov ] * Fix version disparity between App::KGB and kgb-bot 1.07 (2011-07-26) [ Damyan Ivanov ] * Client::Git: use --format=raw when describing annotated tags 1.06 (2010-12-04) [ gregor herrmann ] * kgb-bot: - fix typo when accessing global config - call polygen_available with full class name [ Damyan Ivanov ] * kgb-bot: drop the asterix prefix from revision number * Makefile: fix (real|dist)clean targets to use ./Build for the real work * App::KGB::Change: + fix typo in POD + make the stringification method public and document it * t/52-client-git.t: when comparing changes, force objects to stringify * MANIFEST.SKIP: add MYMETA.yml * fix typo in Client::Subversion POD 1.05 (2010-09-10) * kgb-bot: use File::Which to find polygen binary; split out the polygen-finding function; closes: #593631 * kgb-bot: check existence of polygen binary before using it; closes: #593633 * add gregor to copyright holders * move polygen detection entirely at runtime * any problems in finding polygen binary are logged only when debug is enabled as a counter-measure against remotely-assisted log abuse 1.04 (2010-08-03) * use Digest::SHA from core instead of ::SHA1 * remove references to Svn::* from Build.PL Closes: #582739 (by working around #589812) 1.03 (2010-04-28) * Synchronized versions of kgb-bot and KGB 1.02 (no official release) * Protocol v2 + Adds a new parameter, revision prefix, which is printed plain before the bold commit ID + The default revision prefix is empty ('') + Subversion revision prefix is 'r' 1.01 (2009-12-05) * Client: drop branch/module detection if not all changed paths are in the same branch/module 1.00 (2009-12-02) * ServerRef: send commit_id as a string * Commit: decode UTF-8 log messages * ServerRef: encode all strings before sending 0.16 (2009-11-24) * bot: + print the path information part along the author and revision 0.15 (2009-11-07) * bot: + bump years of copyright + make manual page speak about 'kgb-bot', not 'KGB' + out(): this is a class method, do not print the first argument + remove the '_ECHO_' network * Git: + more robust commit parsing + fix describing newly created branches * client: + fail gracefuly when repo type module is not available * tests + support sending test commits to a live running bot when TEST_KGB_BOT_RUNNING is in the environment 0.14 (2009-11-02) * Git: fix describing merge commits * bot: replace change flags (A+)... with colors * bot: avoid sending changed files list for commits that don't contain changed files * bot: always detect common changes directory 0.13 (2009-11-01) * kgb-bot: fix the code detecting common root for all changes 0.12 (2009-10-31) * add a test ensuring that App::KGB and kgb-bot are the same version * client + honor branch and module supplied by commit + make server choice stable within one client call + Git - drop autodie and check for error when calling open() - when describing changes, use App::KGB::Change objects - fix parsing of multi-line log messages - fix reverse commit order on branch updates - special handling of signed/annotated tags - use raw commit logs to detect file additions/removals 0.11 (2009-10-26) * move generation of a smart answers to a subroutine * make the autoresponder use polygen * fix typo in an error message 0.10 (2009-10-25) * kgb-bot has its own version. no longer pulls the client via App::KGB 0.09 (2009-10-24) * print unhandled IRC stuff only when debugging is enabled * implement logging * drop auto-rejoin TODO item (sort of done) * move discovery of sender's net into a subroutine * respond to CTCP requests * implement !version command * MANIFEST.SKIP: also skip blib * make orig target invoke d/rules clean to ensure the tarball is created off a clean tree * test-server.conf: use local irc server for testing test server considers all local users admins * handle both public and private messages App-KGB-1.31/META.yml000444001750001750 441612203520733 12654 0ustar00damdam000000000000--- abstract: 'collaborative IRC helper' author: - 'Martín Ferrari' - 'Damyan Ivanov' - 'gregor herrmann' build_requires: {} configure_requires: Module::Build: 0.40 perl: 5.010 dynamic_config: 1 generated_by: 'Module::Build version 0.4007, CPAN::Meta::Converter version 2.132140' license: open_source meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: App-KGB no_index: directory: - privinc provides: App::KGB: file: lib/App/KGB.pm version: 1.31 App::KGB::API: file: lib/App/KGB/API.pm version: 4 App::KGB::Change: file: lib/App/KGB/Change.pm version: 1.22 App::KGB::Client: file: lib/App/KGB/Client.pm version: 1.28 App::KGB::Client::CVS: file: lib/App/KGB/Client/CVS.pm version: 1.23 App::KGB::Client::Fake: file: lib/App/KGB/Client/Fake.pm version: 1.17 App::KGB::Client::Git: file: lib/App/KGB/Client/Git.pm version: 1.28 App::KGB::Client::RelayMsg: file: lib/App/KGB/Client/RelayMsg.pm version: 1.27 App::KGB::Client::ServerRef: file: lib/App/KGB/Client/ServerRef.pm version: 1.28 App::KGB::Client::Subversion: file: lib/App/KGB/Client/Subversion.pm version: 1.27 App::KGB::Commit: file: lib/App/KGB/Commit.pm version: 1.27 App::KGB::Commit::Tag: file: lib/App/KGB/Commit/Tag.pm version: 1.28 App::KGB::Painter: file: lib/App/KGB/Painter.pm version: 1.27 JSON::RPC::Client::Any: file: lib/JSON/RPC/Client/Any.pm version: 1.28 WWW::Shorten::Debli: file: lib/WWW/Shorten/Debli.pm version: 0.1 requires: Class::Accessor: 0 Digest::SHA: 0 DirHandle: 0 File::Touch: 0 Git: 0 IPC::Run: 0 IPC::System::Simple: 0 JSON::RPC::Legacy::Client: 0 JSON::XS: 0 POE: 0 POE::Component::IRC: 5.56 POE::Component::Server::SOAP: 0 Proc::PID::File: 0 SOAP::Lite: 0 SVN::Core: 0 SVN::Fs: 0 SVN::Repos: 0 Schedule::RateLimiter: 0 Time::Piece: 0 WWW::Shorten: 0 YAML: 0 perl: 5.010 resources: license: http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt version: 1.31 x_test_requires: Git: 0 SVN::Core: 0 SVN::Fs: 0 SVN::Repos: 0 Test::Compile: 0 Test::Perl::Critic: 0 Test::Pod: 0 Test::Pod::Coverage: 0 Test::Simple: 0.92 YAML: 0 autodie: 0 perl: 5.010 App-KGB-1.31/TODO000444001750001750 424712203520733 12075 0ustar00damdam000000000000* split kgb-bot into manageable modules * start a real test bot for automated tests - this is now possible via eg/start-test-bot-[12] and 'TEST_KGB_BOT_RUNNING=1 make test' even if useful for local testing the results aren't verified via t/*.t * write tests for CVS client * watch file broken; depending on the UA, alioth replies with "406 Not Acceptable" * admin/sync -- needs a plan Plan A ====== - we need a system which would allow individual instances' admins to update some central configuration store, which is both encrypted and signed. - that central store could be fetched by the bots regularly, the signature verified, and then the changes applied. - the central storage could be on alioth, but the signing should be done remotely somehow (who wants to upload her secret hey to alioth? :)) there could be a tool that automates the signing process (download from alioth, start $EDITOR or add config from command line, sign, upload) - the bots need to be given a keyring with trusted keys, whose signatures they recognise Pros: - powerful - possible addition/modification and removal of project - full encryption end-to-end Cons: - GPG integration in the bot - complex configuraion retrieval - changes need time to propagate - non-trivial creation of changes Plan B ====== - bots recognize a new message for adding projects the message is accompanied with a hash over its contents, the timestamp of the sender, and a shared secret (uses the current json protocol implementation, but with another secret) - any of the admins wanting to add project would run a tool which connects with all the bots sending them the signed message Pros: - relatively simple - instant update Cons: - no encryption - only addition of projects (can be addressed by creating another message for project deletion, and assuming that messages for existing projects replace their configuration) Plan C ====== - do nothing. We managed somehow to maintain the service by hand, only with kgb-add-project Pros: - requires no effort Cons: - requires small effort (×3) every now and then App-KGB-1.31/MANIFEST.SKIP000444001750001750 14412203520733 13253 0ustar00damdam000000000000^debian/ \.git \.svn ^_build ^blib ^Build$ MANIFEST.bak ^MYMETA.yml$ ^MYMETA\.json$ ^.pc/ \.*\.swp$ App-KGB-1.31/etc000755001750001750 012203520733 12014 5ustar00damdam000000000000App-KGB-1.31/etc/kgb.conf000444001750001750 333212203520733 13564 0ustar00damdam000000000000# vim: filetype=yaml --- soap: server_addr: 127.0.0.1 server_port: 5391 service_name: KGB queue_limit: 150 log_file: "/var/log/kgb-bot.log" include: "/etc/kgb-bot/kgb.conf.d" repositories: # just a name to identify it foo: # needs to be the same on the client password: ~ # private repositories aren't announced to broadcast channels # private: yes # Some witty answer for people that talk to the bot #smart_answers: # - "I wont speak with you!" # - "Do not disturb!" # - "Leave me alone, I am buzy!" # Admins are allowed some special !commands (currently only !version) #admins: # - some!irc@mask # - some!other@host networks: freenode: nick: KGB ircname: KGB bot username: kgb password: ~ nickserv_password: ~ server: irc.freenode.net port: 6667 channels: # a broadcast channel - name: '#commits' network: freenode broadcast: yes # a channel, tied to one or several repositories - name: '#foo' network: freenode repos: - foo # Can also be set per-channel #smart_answers: # - "I'm in ur channel, watching ur commits!" # - "I am not listening" # - "Shut up! I am buzy watching you." pid_dir: /var/run/kgb-bot # anything less is rejected min_protocol_ver: 1 # default colors: # colors: # repository: bold # revision: bold # author: green # branch: brown # module: purple # path: teal # addition: green # modification: teal # deletion: "bold red" # replacement: reverse # prop_change: underline # web: silver # you can combine them like "bold red" (ouch!) # available colors: black, navy, green, red, brown, purple, orange, yellow, # lime, teal, aqua, blue, fuchsia, gray, silver, white # available modifiers: bold underline reverse App-KGB-1.31/t000755001750001750 012203520733 11504 5ustar00damdam000000000000App-KGB-1.31/t/57-client-git-squash-tags.t000444001750001750 1133112203520733 16573 0ustar00damdam000000000000use strict; use warnings; use autodie qw(:all); use Test::More; BEGIN { eval { require Git; 1 } or plan skip_all => "Git.pm required for testing Git client"; } plan 'no_plan'; use App::KGB::Change; use App::KGB::Client::Git; use App::KGB::Client::ServerRef; use Git; use File::Temp qw(tempdir); use File::Spec; use utf8; my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; my $tmp_cleanup = not $ENV{TEST_KEEP_TMP}; my $dir = tempdir( 'kgb-XXXXXXX', CLEANUP => $tmp_cleanup, DIR => File::Spec->tmpdir ); diag "Temp directory $dir will pe kept" unless $tmp_cleanup; sub write_tmp { my( $fn, $content ) = @_; open my $fh, '>', "$dir/$fn"; print $fh $content; close $fh; } if ( $ENV{TEST_KGB_BOT_DUMP} ) { diag "$ENV{TEST_KGB_BOT_DUMP} will be checked for IRC dump"; truncate( $ENV{TEST_KGB_BOT_DUMP}, 0 ) if -e $ENV{TEST_KGB_BOT_DUMP}; require Test::Differences; Test::Differences->import; } my $dump_fh; sub is_irc_output { return unless my $dump = $ENV{TEST_KGB_BOT_DUMP}; my $wanted = shift; use IO::File; $dump_fh ||= IO::File->new("< $dump") or die "Unable to open $dump: $!"; $dump_fh->binmode(':utf8'); local $/ = undef; $dump_fh->seek( $dump_fh->tell, 0 ); eq_or_diff( "" . <$dump_fh>, $wanted ); } sub strip_irc_colors { my $in = shift; $in =~ s/\x03\d\d//g; $in =~ s/[\x00-\x1f]+//g; return $in; } my $remote = "$dir/there.git"; my $local = "$dir/here"; sub w { my ( $fn, $content ) = @_; write_tmp( "here/$fn", "$content\n" ); } sub a { my ( $fn, $content ) = @_; open my $fh, '>>', "$local/$fn"; print $fh $content, "\n"; close $fh; } mkdir $remote; $ENV{GIT_DIR} = $remote; system 'git', 'init', '--bare'; system( 'git', 'config', 'kgb.tag-squash-message-template', '${{author-name}}${ ({author-login})}${ {project}/}${{module}}${ {log}}' ); use Cwd; my $R = getcwd; my $hook_log; if ( $ENV{TEST_KGB_BOT_RUNNING} or $ENV{TEST_KGB_BOT_DUMP} ) { diag "will try to send notifications to locally running bot"; $hook_log = "$dir/hook.log"; write_tmp 'there.git/hooks/post-receive', <<"EOF"; #!/bin/sh tee -a "$dir/reflog" | PERL5LIB=$R/lib $R/script/kgb-client --repository git --git-reflog - --conf $R/eg/test-client.conf --status-dir $dir >> $hook_log 2>&1 EOF } else { write_tmp 'there.git/hooks/post-receive', <<"EOF"; #!/bin/sh cat >> "$dir/reflog" EOF } chmod 0755, "$dir/there.git/hooks/post-receive"; system("GIT_DIR=$dir/there.git git config --add kgb.squash-threshold 1"); mkdir $local; $ENV{GIT_DIR} = "$local/.git"; mkdir "$local/.git"; system 'git', 'init'; my $git = 'Git'->repository($local); ok( $git, 'local repository allocated' ); isa_ok( $git, 'Git' ); $git->command( 'config', 'user.name', 'Test U. Ser' ); $git->command( 'config', 'user.email', 'ser@example.neverland' ); write_tmp 'reflog', ''; my $c = new_ok( 'App::KGB::Client::Git' => [ { repo_id => 'test', servers => [ App::KGB::Client::ServerRef->new( { uri => "http://127.0.0.1:1234/", password => "hidden", # not used by this client instance } ), ], #br_mod_re => \@br_mod_re, #br_mod_re_swap => $br_mod_re_swap, #ignore_branch => $ignore_branch, git_dir => $remote, reflog => "$dir/reflog", } ] ); sub push_ok { write_tmp 'reflog', ''; unlink $hook_log if $hook_log and -s $hook_log; my $ignore = $git->command( [qw( push origin --all )], { STDERR => 0 } ); $ignore = $git->command( [qw( push origin --tags )], { STDERR => 0 } ); $c->_parse_reflog; $c->_detect_commits; diag `cat $hook_log` if $hook_log and -s $hook_log; } my %commits; sub do_commit { $git->command_oneline( 'commit', '-a', '-m', shift ) =~ /\[(\w+).*\s+(\w+)\]/; push @{ $commits{$1} }, $2; diag "commit $2 in branch $1" unless $tmp_cleanup; } my $commit; ###### first commit w( 'old', 'content' ); $git->command( 'add', '.' ); do_commit('import old content'); $git->command( 'remote', 'add', 'origin', "file://$remote" ); push_ok; $commit = $c->describe_commit; ok( defined($commit), 'first commit exists' ); is( $commit->branch, 'master' ); is( $commit->log, "import old content" ); $commit = $c->describe_commit; is( $commit, undef ); $git->command( tag => "tag-$_" ) for 1..9; push_ok; $commit = $c->describe_commit; like( strip_irc_colors($commit), qr{\($ENV{USER}\) test/there Pushed tag-1, tag-2, 6 other tags and tag-9} ); $commit = $c->describe_commit; is( $commit, undef ); App-KGB-1.31/t/50-client.t000444001750001750 1017412203520733 13551 0ustar00damdam000000000000use strict; use warnings; use autodie qw(:all); use File::Spec::Functions qw( catdir catfile ); use Test::More; BEGIN { eval { require SVN::Core; 1 } or plan skip_all => "SVN::Core required for testing the Subversion client"; eval { require SVN::Fs; 1 } or plan skip_all => "SVN::Fs required for testing the Subversion client"; eval { require SVN::Repos; 1 } or plan skip_all => "SVN::Repos required for testing the Subversion client"; }; plan tests => 30; use utf8; my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use File::Temp qw(tempdir); my $r = tempdir( CLEANUP => not $ENV{TEST_KEEP_TEMP} ); diag "Temporary directory $r will be kept" if $ENV{TEST_KEEP_TEMP}; my $repo = catdir( $r, 'repo' ); my $wd = catdir( $r, 'checkout' ); my $tf = catfile( $wd, 'file' ); sub poke { my $f; open $f, ">", $tf; print $f @_; close $f; } sub in_wd { system 'sh', '-c', "cd $wd && " . shift; } system 'svnadmin', 'create', $repo; my $hook_log; if ( $ENV{TEST_KGB_BOT_RUNNING} ) { diag "will try to send notifications to locally running bot"; use Cwd; $hook_log = catdir( $r, 'hook.log' ); my $R = getcwd; my $h; open $h, '>', "$repo/hooks/post-commit"; print $h <<"EOF"; #!/bin/sh PERL5LIB=$R/lib $R/script/kgb-client --conf $R/eg/test-client.conf --status-dir $r \$1 \$2 >> $hook_log 2>&1 EOF close $h; chmod 0755, "$repo/hooks/post-commit"; } system 'svn', 'checkout', "file://$repo", $wd; poke('one'); in_wd "svn add $tf"; in_wd "svn ci -m 'add file'"; poke('two'); in_wd "svn ci -m 'modify file'"; in_wd "svn rm file"; poke('three'); in_wd "svn add file"; in_wd "svn ci -m 'replace file'"; ok( 1, "Test repository prepared" ); use App::KGB::Client::Subversion; use App::KGB::Client::ServerRef; my $port = 7645; my $password = 'v,sjflir'; my $c = new_ok( 'App::KGB::Client::Subversion' => [ { repo_id => 'test', servers => [ App::KGB::Client::ServerRef->new( { uri => "http://127.0.0.1:$port/", password => $password, } ), ], #br_mod_re => \@br_mod_re, #br_mod_re_swap => $br_mod_re_swap, #ignore_branch => $ignore_branch, repo_path => $repo, revision => 1, } ] ); my $commit = $c->describe_commit; my $me = getpwuid($>); is( $commit->id, 1 ); is( $commit->log, 'add file' ); diag "\$>=$> \$<=$< \$ENV{USER}=$ENV{USER} getpwuid(\$>)=$me"; is( $commit->author, $me ); is( scalar @{ $commit->changes }, 1 ); my $change = $commit->changes->[0]; is( $change->path, '/file' ); ok( not $change->prop_change ); is( $change->action, 'A' ); $c->revision(2); $c->_called(0); $commit = $c->describe_commit; is( $commit->id, 2 ); is( $commit->log, 'modify file' ); is( $commit->author, $me ); is( scalar @{ $commit->changes }, 1 ); $change = $commit->changes->[0]; is( $change->path, '/file' ); ok( not $change->prop_change ); is( $change->action, 'M' ); $c->revision(3); $c->_called(0); $commit = $c->describe_commit; is( $commit->id, 3 ); is( $commit->log, 'replace file' ); is( $commit->author, $me ); is( scalar @{ $commit->changes }, 1 ); $change = $commit->changes->[0]; is( $change->path, '/file' ); ok( not $change->prop_change ); is( $change->action, 'R' ); SKIP: { skip "UTF-8 locale needed for the test with UTF-8 commit message", 7, unless ( ( $ENV{LC_CTYPE} // '' ) =~ /utf-8$/i ); in_wd "svn rm file"; in_wd "svn ci -m 'remove file. Über cool with cyrillics: здрасти'"; $c->revision(4); $c->_called(0); $commit = $c->describe_commit; is( $commit->id, 4 ); is( $commit->log, 'remove file. Über cool with cyrillics: здрасти' ); is( $commit->author, $me ); is( scalar @{ $commit->changes }, 1 ); $change = $commit->changes->[0]; is( $change->path, '/file' ); ok( not $change->prop_change ); is( $change->action, 'D' ); } diag `cat $hook_log` if $hook_log and -s $hook_log; App-KGB-1.31/t/00-compile.t000444001750001750 131112203520733 13667 0ustar00damdam000000000000use Test::More; use Test::Compile::Internal; my $t = Test::Compile::Internal->new(verbose=>1); my @modules = $t->all_pm_files(); eval { require SVN::Core; require SVN::Fs; 1 } or do { $t->diag($@); $t->diag("SVN::Core/Fs unavailable, skipping compilation test of App::KGB::Client::Subversion"); @modules = grep { $_ !~ m,App/KGB/Client/Subversion.pm$, } @modules; }; eval { require Git; 1 } or do { $t->diag($@); $t->diag("Git unavailable, skipping compilation test of App::KGB::Client::Git"); @modules = grep { $_ !~ m,App/KGB/Client/Git.pm$, } @modules; }; $t->plan( tests => scalar(@modules) ); $t->ok( $t->pm_file_compiles($_), "$_ compiles" ) for @modules; $t->done_testing(); App-KGB-1.31/t/54-client-git-squash.t000444001750001750 1350612203520733 15642 0ustar00damdam000000000000use strict; use warnings; use autodie qw(:all); use Test::More; BEGIN { eval { require Git; 1 } or plan skip_all => "Git.pm required for testing Git client"; } plan 'no_plan'; use App::KGB::Change; use App::KGB::Client::Git; use App::KGB::Client::ServerRef; use Git; use File::Temp qw(tempdir); use File::Spec; use utf8; my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; my $tmp_cleanup = not $ENV{TEST_KEEP_TMP}; my $dir = tempdir( 'kgb-XXXXXXX', CLEANUP => $tmp_cleanup, DIR => File::Spec->tmpdir ); diag "Temp directory $dir will pe kept" unless $tmp_cleanup; sub write_tmp { my( $fn, $content ) = @_; open my $fh, '>', "$dir/$fn"; print $fh $content; close $fh; } if ( $ENV{TEST_KGB_BOT_DUMP} ) { diag "$ENV{TEST_KGB_BOT_DUMP} will be checked for IRC dump"; truncate( $ENV{TEST_KGB_BOT_DUMP}, 0 ) if -e $ENV{TEST_KGB_BOT_DUMP}; require Test::Differences; Test::Differences->import; } my $dump_fh; sub is_irc_output { return unless my $dump = $ENV{TEST_KGB_BOT_DUMP}; my $wanted = shift; use IO::File; $dump_fh ||= IO::File->new("< $dump") or die "Unable to open $dump: $!"; $dump_fh->binmode(':utf8'); local $/ = undef; $dump_fh->seek( $dump_fh->tell, 0 ); eq_or_diff( "" . <$dump_fh>, $wanted ); } sub strip_irc_colors { my $in = shift; $in =~ s/\x03\d\d//g; $in =~ s/[\x00-\x1f]+//g; return $in; } my $remote = "$dir/there.git"; my $local = "$dir/here"; sub w { my ( $fn, $content ) = @_; write_tmp( "here/$fn", "$content\n" ); } sub a { my ( $fn, $content ) = @_; open my $fh, '>>', "$local/$fn"; print $fh $content, "\n"; close $fh; } mkdir $remote; $ENV{GIT_DIR} = $remote; system 'git', 'init', '--bare'; use Cwd; my $R = getcwd; my $hook_log; system( 'git', 'config', 'kgb.squash-message-template', '${{author-name}}${ ({author-login})}${ {branch}}${ {commit}}${ {project}/}${{module}}${ {log}}' ); if ( $ENV{TEST_KGB_BOT_RUNNING} or $ENV{TEST_KGB_BOT_DUMP} ) { diag "will try to send notifications to locally running bot"; $hook_log = "$dir/hook.log"; write_tmp 'there.git/hooks/post-receive', <<"EOF"; #!/bin/sh tee -a "$dir/reflog" | PERL5LIB=$R/lib $R/script/kgb-client --repository git --git-reflog - --conf $R/eg/test-client.conf --status-dir $dir >> $hook_log 2>&1 EOF } else { write_tmp 'there.git/hooks/post-receive', <<"EOF"; #!/bin/sh cat >> "$dir/reflog" EOF } chmod 0755, "$dir/there.git/hooks/post-receive"; system("GIT_DIR=$dir/there.git git config --add kgb.squash-threshold 1"); mkdir $local; $ENV{GIT_DIR} = "$local/.git"; mkdir "$local/.git"; system 'git', 'init'; my $git = 'Git'->repository($local); ok( $git, 'local repository allocated' ); isa_ok( $git, 'Git' ); $git->command( 'config', 'user.name', 'Test U. Ser' ); $git->command( 'config', 'user.email', 'ser@example.neverland' ); write_tmp 'reflog', ''; my $c = new_ok( 'App::KGB::Client::Git' => [ { repo_id => 'test', servers => [ App::KGB::Client::ServerRef->new( { uri => "http://127.0.0.1:1234/", password => "hidden", # not used by this client instance } ), ], #br_mod_re => \@br_mod_re, #br_mod_re_swap => $br_mod_re_swap, #ignore_branch => $ignore_branch, git_dir => $remote, reflog => "$dir/reflog", } ] ); sub push_ok { write_tmp 'reflog', ''; unlink $hook_log if $hook_log and -s $hook_log; my $ignore = $git->command( [qw( push origin --all )], { STDERR => 0 } ); $ignore = $git->command( [qw( push origin --tags )], { STDERR => 0 } ); $c->_parse_reflog; $c->_detect_commits; diag `cat $hook_log` if $hook_log and -s $hook_log; } my %commits; sub do_commit { $git->command_oneline( 'commit', '-a', '-m', shift ) =~ /\[(\w+).*\s+(\w+)\]/; push @{ $commits{$1} }, $2; diag "commit $2 in branch $1" unless $tmp_cleanup; } my $commit; ###### first commit w( 'old', 'content' ); $git->command( 'add', '.' ); do_commit('import old content'); $git->command( 'remote', 'add', 'origin', "file://$remote" ); push_ok; $commit = $c->describe_commit; ok( defined($commit), 'first commit exists' ); is( $commit->branch, 'master' ); is( $commit->log, "import old content" ); w( 'new', 'content' ); $git->command( 'add', 'new' ); $git->command( 'commit', '-m', 'created new content' ); w( 'new', 'more content' ); $git->command( 'commit', '-a', '-m', 'updated new content' ); a( 'new', 'even more content' ); $git->command( 'commit', '-a', '-m', 'another update' ); push_ok; $commit = $c->describe_commit; ok( defined($commit), 'squashed commit exists' ) or BAIL_OUT 'will fail anyway'; ok( !ref($commit), 'squashed commit is a plain string' ) or BAIL_OUT 'will fail anyway'; like( strip_irc_colors($commit), qr/\($ENV{USER}\) master [0-9a-f]{7} test\/there 3 commits pushed, 1 file changed, 2\(\+\)$/ ); ### multiple commits in a new branch $git->command( 'checkout', '-q', '-b', 'feature', 'master' ); a( 'new', 'additional content' ); do_commit( 'additional content in a new branch' ); a( 'new', 'even more additional content' ); do_commit( 'second commit in the new branch' ); push_ok; $commit = $c->describe_commit; ok( defined($commit), 'squashed new branch commit exists' ) or BAIL_OUT "premature end of commits"; ok( !ref($commit), 'squashed commit is a plain string' ) or BAIL_OUT "will fail with $commit anyway"; like( strip_irc_colors($commit), qr/\($ENV{USER}\) feature [0-9a-f]{7} test\/there New branch with 2 commits pushed, 1 file changed, 2\(\+\) since master\/[0-9a-f]{7}/ ); ##### No more commits after the last $commit = $c->describe_commit; is( $commit, undef ); App-KGB-1.31/t/00-compile_shell_scripts.t000444001750001750 12012203520733 16602 0ustar00damdam000000000000use Test::More tests => 1; use autodie; system 'sh -n eg/post-commit'; ok(1); App-KGB-1.31/t/30-bot-changes.t000444001750001750 102012203520733 14431 0ustar00damdam000000000000use Test::More tests => 3; use App::KGB::Change; sub is_common_dir { my ( $cs, $wanted ) = @_; is( App::KGB::Change->detect_common_dir( [ map ( App::KGB::Change->new($_), @$cs ) ] ), $wanted ); } is_common_dir( [ '(A)foo/bar', '(A)foo/dar', '(A)foo/bar/dar' ], 'foo' ); is_common_dir( [ '(A)debian/patches/series', '(A)debian/patches/moo.patch' ], 'debian/patches' ); is_common_dir( [ 'trunk/packages/po/sublevel4/vi.po', 'trunk/packages/po/sublevel3/vi.po' ], 'trunk/packages/po' ); App-KGB-1.31/t/00-compile_scripts.t000444001750001750 43212203520733 15421 0ustar00damdam000000000000use Test::More; use Test::Compile::Internal; my $t = Test::Compile::Internal->new( verbose => 1 ); my @scripts = $t->all_pl_files; $t->plan( tests => scalar(@scripts) ); for my $file (@scripts) { $t->ok( $t->pl_file_compiles($file), "$file compiles" ); } $t->done_testing; App-KGB-1.31/t/version.t000444001750001750 70212203520733 13472 0ustar00damdam000000000000#!perl -T use strict; use warnings; use Test::More tests => 1; use App::KGB; my $app_kgb_version = $App::KGB::VERSION; my $kgb_bot_version; my $f; open( $f, "script/kgb-bot" ); while ( defined( $_ = <$f> ) ) { chomp; if ( /^our \$VERSION = '(.+)';$/ ) { $kgb_bot_version = $1; last; } } ok( $app_kgb_version eq $kgb_bot_version, "App::KGB version ($app_kgb_version) matches kgb-bot version ($kgb_bot_version)" ); App-KGB-1.31/t/56-client-git-ff-merge-2.t000444001750001750 1161412203520733 16165 0ustar00damdam000000000000use strict; use warnings; use autodie qw(:all); use Test::More; BEGIN { eval { require Git; 1 } or plan skip_all => "Git.pm required for testing Git client"; } plan 'no_plan'; use App::KGB::Change; use App::KGB::Client::Git; use App::KGB::Client::ServerRef; use Git; use File::Temp qw(tempdir); use File::Spec; use utf8; my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; my $tmp_cleanup = not $ENV{TEST_KEEP_TMP}; my $dir = tempdir( 'kgb-XXXXXXX', CLEANUP => $tmp_cleanup, DIR => File::Spec->tmpdir ); diag "Temp directory $dir will pe kept" unless $tmp_cleanup; sub write_tmp { my( $fn, $content ) = @_; open my $fh, '>', "$dir/$fn"; print $fh $content; close $fh; } if ( $ENV{TEST_KGB_BOT_DUMP} ) { diag "$ENV{TEST_KGB_BOT_DUMP} will be checked for IRC dump"; truncate( $ENV{TEST_KGB_BOT_DUMP}, 0 ) if -e $ENV{TEST_KGB_BOT_DUMP}; require Test::Differences; Test::Differences->import; } my $dump_fh; sub is_irc_output { return unless my $dump = $ENV{TEST_KGB_BOT_DUMP}; my $wanted = shift; use IO::File; $dump_fh ||= IO::File->new("< $dump") or die "Unable to open $dump: $!"; $dump_fh->binmode(':utf8'); local $/ = undef; $dump_fh->seek( $dump_fh->tell, 0 ); eq_or_diff( "" . <$dump_fh>, $wanted ); } my $remote = "$dir/there.git"; my $local = "$dir/here"; sub w { my ( $fn, $content ) = @_; write_tmp( "here/$fn", "$content\n" ); } sub a { my ( $fn, $content ) = @_; open my $fh, '>>', "$local/$fn"; print $fh $content, "\n"; close $fh; } mkdir $remote; $ENV{GIT_DIR} = $remote; system 'git', 'init', '--bare'; use Cwd; my $R = getcwd; my $hook_log; if ( $ENV{TEST_KGB_BOT_RUNNING} or $ENV{TEST_KGB_BOT_DUMP} ) { diag "will try to send notifications to locally running bot"; $hook_log = "$dir/hook.log"; write_tmp 'there.git/hooks/post-receive', <<"EOF"; #!/bin/sh tee -a "$dir/reflog" | PERL5LIB=$R/lib $R/script/kgb-client --conf $R/eg/test-client.conf --status-dir $dir >> $hook_log 2>&1 EOF } else { write_tmp 'there.git/hooks/post-receive', <<"EOF"; #!/bin/sh cat >> "$dir/reflog" EOF } chmod 0755, "$dir/there.git/hooks/post-receive"; mkdir $local; $ENV{GIT_DIR} = "$local/.git"; mkdir "$local/.git"; system 'git', 'init'; my $git = 'Git'->repository($local); ok( $git, 'local repository allocated' ); isa_ok( $git, 'Git' ); $git->command( 'config', 'user.name', 'Test U. Ser' ); $git->command( 'config', 'user.email', 'ser@example.neverland' ); write_tmp 'reflog', ''; my $c = new_ok( 'App::KGB::Client::Git' => [ { repo_id => 'test', servers => [ App::KGB::Client::ServerRef->new( { uri => "http://127.0.0.1:1234/", password => "hidden", # not used by this client instance } ), ], #br_mod_re => \@br_mod_re, #br_mod_re_swap => $br_mod_re_swap, #ignore_branch => $ignore_branch, git_dir => $remote, reflog => "$dir/reflog", } ] ); sub push_ok { write_tmp 'reflog', ''; unlink $hook_log if $hook_log and -s $hook_log; my $ignore = $git->command( [qw( push origin --all )], { STDERR => 0 } ); $ignore = $git->command( [qw( push origin --tags )], { STDERR => 0 } ); $c->_parse_reflog; $c->_detect_commits; diag `cat $hook_log` if $hook_log and -s $hook_log; } my %commits; sub do_commit { $git->command_oneline( 'commit', '-a', '-m', shift ) =~ /\[(\w+).*\s+(\w+)\]/; push @{ $commits{$1} }, $2; diag "commit $2 in branch $1" unless $tmp_cleanup; return $2; } my $commit; ###### first commit w( 'old', 'content' ); $git->command( 'add', '.' ); do_commit('import old content'); $git->command( 'remote', 'add', 'origin', "file://$remote" ); push_ok; $commit = $c->describe_commit; ok( defined($commit), 'initial import commit' ); is( $c->describe_commit, undef, 'no more commits' ); #### branch, two changes, merge. then the changes should be reported only once my $b1 = 'separate'; $git->command( [ 'checkout', '-b', $b1, 'master' ], { STDERR => 0 } ); w( 'new', 'content' ); $git->command( 'add', 'new' ); my $c1 = do_commit('created new content'); push_ok; $commit = $c->describe_commit; ok( defined($commit), 'changing commit' ); is( $commit->branch, $b1, "branch is '$b1'" ); is( $commit->log, 'created new content' ); is( $c->describe_commit, undef, 'no more commits' ); $git->command( 'checkout', '-q', 'master' ); $git->command( 'merge', '--ff', $b1 ); push_ok; $commit = $c->describe_commit; ok( defined($commit), 'ff commit exists' ); is( $commit->branch, 'master' ); is( $commit->id, $c1 ); is( $commit->log, "fast forward" ); ##### No more commits after the last $commit = $c->describe_commit; is( $commit, undef ); App-KGB-1.31/t/pod.t000444001750001750 43012203520733 12565 0ustar00damdam000000000000#!perl -T use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok( all_pod_files(), all_pod_files( glob('man*') ) ); App-KGB-1.31/t/55-client-git-merges-ff.t000444001750001750 1162612203520733 16213 0ustar00damdam000000000000use strict; use warnings; use autodie qw(:all); use Test::More; BEGIN { eval { require Git; 1 } or plan skip_all => "Git.pm required for testing Git client"; } plan 'no_plan'; use App::KGB::Change; use App::KGB::Client::Git; use App::KGB::Client::ServerRef; use Git; use File::Temp qw(tempdir); use File::Spec; use utf8; my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; my $tmp_cleanup = not $ENV{TEST_KEEP_TMP}; my $dir = tempdir( 'kgb-XXXXXXX', CLEANUP => $tmp_cleanup, DIR => File::Spec->tmpdir ); diag "Temp directory $dir will pe kept" unless $tmp_cleanup; sub write_tmp { my( $fn, $content ) = @_; open my $fh, '>', "$dir/$fn"; print $fh $content; close $fh; } if ( $ENV{TEST_KGB_BOT_DUMP} ) { diag "$ENV{TEST_KGB_BOT_DUMP} will be checked for IRC dump"; truncate( $ENV{TEST_KGB_BOT_DUMP}, 0 ) if -e $ENV{TEST_KGB_BOT_DUMP}; require Test::Differences; Test::Differences->import; } my $dump_fh; sub is_irc_output { return unless my $dump = $ENV{TEST_KGB_BOT_DUMP}; my $wanted = shift; use IO::File; $dump_fh ||= IO::File->new("< $dump") or die "Unable to open $dump: $!"; $dump_fh->binmode(':utf8'); local $/ = undef; $dump_fh->seek( $dump_fh->tell, 0 ); eq_or_diff( "" . <$dump_fh>, $wanted ); } my $remote = "$dir/there.git"; my $local = "$dir/here"; sub w { my ( $fn, $content ) = @_; write_tmp( "here/$fn", "$content\n" ); } sub a { my ( $fn, $content ) = @_; open my $fh, '>>', "$local/$fn"; print $fh $content, "\n"; close $fh; } mkdir $remote; $ENV{GIT_DIR} = $remote; system 'git', 'init', '--bare'; use Cwd; my $R = getcwd; my $hook_log; if ( $ENV{TEST_KGB_BOT_RUNNING} or $ENV{TEST_KGB_BOT_DUMP} ) { diag "will try to send notifications to locally running bot"; system qw( git config --add kgb.conf ), "$R/eg/test-client.conf"; $hook_log = "$dir/hook.log"; write_tmp 'there.git/hooks/post-receive', <<"EOF"; #!/bin/sh tee -a "$dir/reflog" | PERL5LIB=$R/lib $R/script/kgb-client >> $hook_log 2>&1 EOF } else { write_tmp 'there.git/hooks/post-receive', <<"EOF"; #!/bin/sh cat >> "$dir/reflog" EOF } chmod 0755, "$dir/there.git/hooks/post-receive"; mkdir $local; $ENV{GIT_DIR} = "$local/.git"; mkdir "$local/.git"; system 'git', 'init'; my $git = 'Git'->repository($local); ok( $git, 'local repository allocated' ); isa_ok( $git, 'Git' ); $git->command( 'config', 'user.name', 'Test U. Ser' ); $git->command( 'config', 'user.email', 'ser@example.neverland' ); write_tmp 'reflog', ''; my $c = new_ok( 'App::KGB::Client::Git' => [ { repo_id => 'test', servers => [ App::KGB::Client::ServerRef->new( { uri => "http://127.0.0.1:1234/", password => "hidden", # not used by this client instance } ), ], #br_mod_re => \@br_mod_re, #br_mod_re_swap => $br_mod_re_swap, #ignore_branch => $ignore_branch, git_dir => $remote, reflog => "$dir/reflog", } ] ); sub push_ok { write_tmp 'reflog', ''; unlink $hook_log if $hook_log and -s $hook_log; my $ignore = $git->command( [qw( push origin --all )], { STDERR => 0 } ); $ignore = $git->command( [qw( push origin --tags )], { STDERR => 0 } ); $c->_parse_reflog; $c->_detect_commits; diag `cat $hook_log` if $hook_log and -s $hook_log; } my %commits; sub do_commit { $git->command_oneline( 'commit', '-a', '-m', shift ) =~ /\[(\w+).*\s+(\w+)\]/; push @{ $commits{$1} }, $2; diag "commit $2 in branch $1" unless $tmp_cleanup; } my $commit; ###### first commit w( 'old', 'content' ); $git->command( 'add', '.' ); do_commit('import old content'); $git->command( 'remote', 'add', 'origin', "file://$remote" ); push_ok; $commit = $c->describe_commit; ok( defined($commit), 'initial import commit' ); is( $c->describe_commit, undef, 'no more commits' ); #### branch, push my $b1 = 'develop'; $git->command( [ 'checkout', '-b', $b1, 'master' ], { STDERR => 0 } ); push_ok; $commit = $c->describe_commit; is( $commit->branch, $b1 ); is( $commit->log, 'branch created' ); $commit = $c->describe_commit; is( $commit, undef ); #### one commit on the branch, merge. then the changes should be reported only once w( 'new', 'content' ); $git->command( 'add', 'new' ); $git->command( 'commit', '-m', 'created new content' ); $git->command( 'checkout', '-q', 'master' ); $git->command( 'merge', '--ff', $b1 ); push_ok(); $commit = $c->describe_commit; is( $commit->branch, 'master' ); is( $commit->log, 'created new content' ); $commit = $c->describe_commit; is( $commit->branch, $b1 ); is( $commit->log, 'fast forward' ); ##### No more commits after the last $commit = $c->describe_commit; is( $commit, undef ); App-KGB-1.31/t/51-client_branch_module.t000444001750001750 665412203520733 16424 0ustar00damdam000000000000use strict; use warnings; use autodie qw(:all); use Test::More; BEGIN { eval { require SVN::Core; 1 } or plan skip_all => "SVN::Core required for testing the Subversion client"; eval { require SVN::Fs; 1 } or plan skip_all => "SVN::Fs required for testing the Subversion client"; eval { require SVN::Repos; 1 } or plan skip_all => "SVN::Repos required for testing the Subversion client"; }; plan tests => 1+8*3; use App::KGB::Change; use App::KGB::Client::Subversion; use App::KGB::Client::ServerRef; my $port = 7645; my $password = 'v,sjflir'; my $c = new_ok( 'App::KGB::Client::Subversion' => [ { repo_id => 'test', servers => [ App::KGB::Client::ServerRef->new( { uri => "http://127.0.0.1:$port/", password => $password, } ), ], #br_mod_re => \@br_mod_re, #br_mod_re_swap => $br_mod_re_swap, #ignore_branch => $ignore_branch, repo_path => '/', revision => 1, } ] ); sub test_matching { my ( $test_name, $files, $res, $swap, $wanted_branch, $wanted_module, $rest ) = @_; $files = [$files] unless ref($files); $res = [$res] unless ref($res); my $changes = [ map { App::KGB::Change->new( { action => 'M', path => $_, } ) } @$files ]; if ($swap) { $c->mod_br_re($res); $c->br_mod_re( [] ); } else { $c->br_mod_re($res); $c->mod_br_re( [] ); } my ( $branch, $module ) = $c->detect_branch_and_module( $changes ); is( $branch, $wanted_branch, "branch detection in [$test_name] (@$files) =~ (@$res)" ); is( $module, $wanted_module, "module detection in [$test_name] (@$files) =~ (@$res)" ); is( "@$changes", $rest, "file list for [$test_name]" ); } test_matching( 'module and branch', '/kgb/trunk/some/file', '^/([^/]+)/([^/]+)/', 1, 'trunk', 'kgb', 'some/file', ); test_matching( 'branch and module', '/trunk/kgb/some/file', '^/([^/]+)/([^/]+)/', 0, 'trunk', 'kgb', 'some/file', ); test_matching( 'branch only', '/trunk/some/file', '^/([^/]+)/()', 0, 'trunk', '', 'some/file', ); test_matching( 'module only', '/website/some/file', '^/(website)/()', 1, '', 'website', 'some/file', ); test_matching( 'real example', 'kgb/trunk/script/kgb-bot', [ "^([^/]+)/(trunk|tags)/", "^([^/]+)/branches/([^/]+)/", "^(website)/()", ], 1, 'trunk', 'kgb', 'script/kgb-bot', ); test_matching( 'multi-file in one dir', [ 'kgb/trunk/script/kgb-bot', 'kgb/trunk/script/kgb-client' ], [ "^([^/]+)/(trunk|tags)/", "^([^/]+)/branches/([^/]+)/", "^(website)/()", ], 1, 'trunk', 'kgb', 'script/kgb-bot script/kgb-client', ); test_matching( 'multi-module', [ 'trunk/foo/debian/moo', 'trunk/bar/debian/goo' ], [ "^(trunk|tags)/([^/]+)/", "^branches/([^/]+)/([^/]+)/", "^(website)/()", ], 0, undef, undef, 'trunk/foo/debian/moo trunk/bar/debian/goo', ); test_matching( 'multi-module with separated modules', [ 'foo/trunk/debian/moo', 'bar/trunk/debian/goo' ], [ "^([^/]+)/(trunk|tags)/", "^([^/]+)/branches/([^/]+)/", "^(website)/()", ], 1, undef, undef, 'foo/trunk/debian/moo bar/trunk/debian/goo', ); App-KGB-1.31/t/perlcriticrc000444001750001750 24012203520733 14225 0ustar00damdam000000000000only = 1 include = Variables::ProhibitConditionalDeclarations include = TestingAndDebugging::RequireUseWarnings include = TestingAndDebugging::RequireUseStrict App-KGB-1.31/t/52-client-git.t000444001750001750 2556612203520733 14347 0ustar00damdam000000000000use strict; use warnings; use autodie qw(:all); use Test::More; BEGIN { eval { require Git; 1 } or plan skip_all => "Git.pm required for testing Git client"; } plan 'no_plan'; use App::KGB::Change; use App::KGB::Client::Git; use App::KGB::Client::ServerRef; use Git; use File::Temp qw(tempdir); use File::Spec; use utf8; my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; my $tmp_cleanup = not $ENV{TEST_KEEP_TMP}; my $dir = tempdir( 'kgb-XXXXXXX', CLEANUP => $tmp_cleanup, DIR => File::Spec->tmpdir ); diag "Temp directory $dir will pe kept" unless $tmp_cleanup; sub write_tmp { my( $fn, $content ) = @_; open my $fh, '>', "$dir/$fn"; print $fh $content; close $fh; } if ( $ENV{TEST_KGB_BOT_DUMP} ) { diag "$ENV{TEST_KGB_BOT_DUMP} will be checked for IRC dump"; truncate( $ENV{TEST_KGB_BOT_DUMP}, 0 ) if -e $ENV{TEST_KGB_BOT_DUMP}; require Test::Differences; Test::Differences->import; } my $dump_fh; sub is_irc_output { return unless my $dump = $ENV{TEST_KGB_BOT_DUMP}; my $wanted = shift; use IO::File; $dump_fh ||= IO::File->new("< $dump") or die "Unable to open $dump: $!"; $dump_fh->binmode(':utf8'); local $/ = undef; $dump_fh->seek( $dump_fh->tell, 0 ); eq_or_diff( "" . <$dump_fh>, $wanted ); } my $remote = "$dir/there.git"; my $local = "$dir/here"; sub w { my ( $fn, $content ) = @_; write_tmp( "here/$fn", "$content\n" ); } sub a { my ( $fn, $content ) = @_; open my $fh, '>>', "$local/$fn"; print $fh $content, "\n"; close $fh; } mkdir $remote; $ENV{GIT_DIR} = $remote; system 'git', 'init', '--bare'; use Cwd; my $R = getcwd; my $hook_log; if ( $ENV{TEST_KGB_BOT_RUNNING} or $ENV{TEST_KGB_BOT_DUMP} ) { diag "will try to send notifications to locally running bot"; $hook_log = "$dir/hook.log"; write_tmp 'there.git/hooks/post-receive', <<"EOF"; #!/bin/sh tee -a "$dir/reflog" | PERL5LIB=$R/lib $R/script/kgb-client --git-reflog - --conf $R/eg/test-client.conf --status-dir $dir >> $hook_log 2>&1 EOF } else { write_tmp 'there.git/hooks/post-receive', <<"EOF"; #!/bin/sh cat >> "$dir/reflog" EOF } chmod 0755, "$dir/there.git/hooks/post-receive"; mkdir $local; $ENV{GIT_DIR} = "$local/.git"; mkdir "$local/.git"; system 'git', 'init'; my $git = 'Git'->repository($local); ok( $git, 'local repository allocated' ); isa_ok( $git, 'Git' ); $git->command( 'config', 'user.name', 'Test U. Ser' ); $git->command( 'config', 'user.email', 'ser@example.neverland' ); write_tmp 'reflog', ''; my $c = new_ok( 'App::KGB::Client::Git' => [ { repo_id => 'test', servers => [ App::KGB::Client::ServerRef->new( { uri => "http://127.0.0.1:1234/", password => "hidden", # not used by this client instance } ), ], #br_mod_re => \@br_mod_re, #br_mod_re_swap => $br_mod_re_swap, #ignore_branch => $ignore_branch, git_dir => $remote, reflog => "$dir/reflog", } ] ); sub push_ok { write_tmp 'reflog', ''; unlink $hook_log if $hook_log and -s $hook_log; my $ignore = $git->command( [qw( push origin --all )], { STDERR => 0 } ); $ignore = $git->command( [qw( push origin --tags )], { STDERR => 0 } ); $c->_parse_reflog; $c->_detect_commits; diag `cat $hook_log` if $hook_log and -s $hook_log; } my %commits; sub do_commit { $git->command_oneline( 'commit', '-m', shift ) =~ /\[(\w+).*\s+(\w+)\]/; push @{ $commits{$1} }, $2; diag "commit $2 in branch $1" unless $tmp_cleanup; } ###### first commit w( 'a', 'some content' ); $git->command( 'add', '.' ); do_commit('initial import'); $git->command( 'remote', 'add', 'origin', "file://$remote" ); push_ok; # now "$dir/reflog" shall have some refs #diag "Looking for the reflog in '$dir/reflog'"; ok -s "$dir/reflog", "post-receive hook logs"; my $commit = $c->describe_commit; ok( defined($commit), 'commit 1 present' ); is( $commit->branch, 'master' ); is( $commit->id, shift @{ $commits{master} } ); is( $commit->log, "initial import" ); is( $commit->author, 'ser' ); is( scalar @{ $commit->changes }, 1 ); is( $commit->changes->[0]->as_string, '(A)a' ); is_irc_output( "#test ser master ".$commit->id." a * initial import\n" ); ##### modify and add a 'a', 'some other content'; w 'b', 'some other content'; $git->command( 'add', '.' ); do_commit('some changes'); push_ok(); $commit = $c->describe_commit; ok( defined($commit), 'commit 2 present' ); is( $commit->branch, 'master' ); is( $commit->id, shift @{ $commits{master} } ); is( $commit->log, "some changes" ); is( $commit->author, 'ser' ); is( scalar @{ $commit->changes }, 2 ); is( $commit->changes->[0]->as_string, 'a' ); is( $commit->changes->[1]->as_string, '(A)b' ); is_irc_output("#test ser master ".$commit->id." a b * some changes\n"); ##### remove, banch, modyfy, add, tag; batch send $git->command( 'rm', 'a' ); do_commit('a removed'); $git->command( 'checkout', '-q', '-b', 'other', 'master' ); w 'c', 'a new file was born'; w 'b', 'new content'; $git->command( 'add', '.' ); do_commit('a change in the other branch'); $git->command( 'tag', '1.0-beta' ); push_ok(); my $other_branch_point = $commits{master}[0]; my $c1 = $commit = $c->describe_commit; ok( defined($commit), 'commit 3 present' ); is( $commit->branch, 'master', 'commit 3 branch is "master"' ); is( $commit->id, shift @{ $commits{master} } ); is( $commit->log, "a removed" ); is( $commit->author, 'ser' ); is( scalar @{ $commit->changes }, 1 ); is( $commit->changes->[0]->as_string, '(D)a' ); my $c2 = $commit = $c->describe_commit; ok( defined($commit), 'commit 4 present' ); is( $commit->branch, 'other' ); is( $commit->id, shift @{ $commits{other} } ); is( $commit->log, "a change in the other branch" ); is( $commit->author, 'ser' ); is( scalar @{ $commit->changes }, 2 ); is( $commit->changes->[0]->as_string, 'b' ); is( $commit->changes->[1]->as_string, '(A)c' ); my $tagged = $commit->id; $commit = $c->describe_commit; ok( defined($commit), 'commit 5 present' ); is( $commit->id, $tagged, "commit 5 id" ); is( $commit->branch, 'tags', "commit 5 branch" ); is( $commit->log, "tag '1.0-beta' created", "commit 5 log" ); is( $commit->author, undef, "commit 5 author" ); is( $commit->changes->[0]->as_string, '(A)1.0-beta', "commit 5 changes" ); is_irc_output("#test ser master ".$c1->id." a * a removed #test ser other ".$c2->id." b c * a change in the other branch #test tags ".$c2->id." 1.0-beta * tag '1.0-beta' created\n"); ##### annotated tag mkdir( File::Spec->catdir($local, 'debian') ); w( File::Spec->catfile( 'debian', 'README' ), 'You read this!? Good boy/girl.' ); $git->command( 'add', 'debian' ); do_commit( "add README for release\n\nas everybody knows, releases have to have READMEs\nHello, hi!" ); $git->command( 'tag', '-a', '-m', 'Release 1.0', '1.0-release' ); push_ok(); $c1 = $commit = $c->describe_commit; ok( defined($commit), 'commit 6 present' ); is( $commit->id, shift @{ $commits{other} } ); is( $commit->branch, 'other' ); is( $commit->log, "add README for release\n\nas everybody knows, releases have to have READMEs\nHello, hi!" ); is( $commit->author, 'ser' ); is( scalar @{ $commit->changes }, 1 ); is( $commit->changes->[0]->as_string, '(A)debian/README' ); $tagged = $commit->id; $c2 = $commit = $c->describe_commit; ok( defined($commit), 'annotated tag here' ); is( $commit->branch, 'tags' ); is( $commit->author, 'ser' ); is( scalar( @{ $commit->changes } ), 1 ); is( $commit->changes->[0]->as_string, '(A)1.0-release' ); is( $commit->log, "Release 1.0 (tagged commit: $tagged)", 'annotated tag log' ); is_irc_output("#test ser other ".$c1->id." debian/README * add README for release #test ser tags ".$c2->id." 1.0-release * Release 1.0 (tagged commit: ".$c1->id.") "); # a hollow branch $git->command('branch', 'hollow'); push_ok(); # hollow branches are not detected for now $commit = $c->describe_commit; ok( defined($commit), 'hollow branch described' ); is( $commit->id, $tagged, "hollow commit is $tagged" ); is( $commit->branch, 'hollow', "hollow commit branch is 'hollow'" ); is( scalar( @{ $commit->changes } ), 0, "no changes in hollow commit" ); is( $commit->log, "branch created", "hollow commit log is 'branch created'" ); $commit = $c->describe_commit; ok( !defined($commit), 'hollow branch has no commits' ); #is_irc_output("#test ser hollow ".$commit->id." * branch created\n"); # some UTF-8 w 'README', 'You dont read this!? Bad!'; $git->command( 'add', '.' ); do_commit( "update readme with an über cléver cómmít with cyrillics: привет" ); push_ok(); $commit = $c->describe_commit; ok( defined($commit), 'UTF-8 commit exists' ); is( $commit->branch, 'other' ); is( $commit->author, 'ser' ); is( scalar( @{ $commit->changes } ), 1 ); is( $commit->log, "update readme with an über cléver cómmít with cyrillics: привет" ); is_irc_output("#test ser other ".$commit->id." README * update readme with an über cléver cómmít with cyrillics: привет\n"); # parent-less branch write_tmp 'reflog', ''; $git->command( [ 'checkout', '--orphan', 'allnew' ], { STDERR => 0 } ); $git->command( 'rm', '-rf', '.' ); $git->command( 'commit', '--allow-empty', '-m', 'created empty branch allnew' ); $git->command( [ 'push', '-u', 'origin', 'allnew' ], { STDERR => 0 } ); $c->_parse_reflog; $c->_detect_commits; $commit = $c->describe_commit; ok( defined($commit), 'empty branch creation commit exists' ); is( $commit->branch, 'allnew', 'empty branch name' ); is( $commit->log, "created empty branch allnew", 'empty branch log' ); is_irc_output("#test ser allnew ".$commit->id." * created empty branch allnew\n"); ##### No more commits after the last $commit = $c->describe_commit; is( $commit, undef ); # now the same on the master branch $git->command( [ 'checkout', '-q', 'master' ], { STDERR => 0 } ); $git->command( 'merge', 'allnew' ); push_ok(); $c2 = $commit = $c->describe_commit; ok( defined($commit), 'empty branch merge commit exists' ); is( $commit->branch, 'master' ); is( $commit->log, "Merge branch 'allnew'" ); is_irc_output("#test ser master ".$c2->id." * Merge branch 'allnew'\n"); $git->command( checkout => '-q', 'other' ); mkdir( File::Spec->catdir( $local, 'debian', 'patches' ) ); w( File::Spec->catfile( 'debian', 'patches', 'series' ), 'some.patch' ); w( File::Spec->catfile( 'debian', 'patches', 'some.patch' ), 'This is a patch' ); $git->command( add => 'debian' ); $git->command( commit => -m => 'A change in two files' ); push_ok(); $commit = $c->describe_commit; is_irc_output( "#test ser other " . $commit->id . " debian/patches/ series some.patch * A change in two files\n" ); ##### No more commits after the last $commit = $c->describe_commit; is( $commit, undef ); $commit = $c->describe_commit; is( $commit, undef ); App-KGB-1.31/t/pod-coverage.t000444001750001750 104712203520733 14403 0ustar00damdam000000000000use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); App-KGB-1.31/t/critic.t000444001750001750 54612203520733 13270 0ustar00damdam000000000000use strict; use warnings; use Test::More; BEGIN { eval { require Test::Perl::Critic; 1 } or plan skip_all => 'Test::Perl::Critic required to criticise code'; }; use Carp qw(croak); use File::Spec; my $rcfile = File::Spec->catfile( 't', 'perlcriticrc' ); Test::Perl::Critic->import( -profile => $rcfile ); all_critic_ok( 'scripts', 'lib' ); App-KGB-1.31/t/53-client-git-merges.t000444001750001750 1403212203520733 15612 0ustar00damdam000000000000use strict; use warnings; use autodie qw(:all); use Test::More; BEGIN { eval { require Git; 1 } or plan skip_all => "Git.pm required for testing Git client"; } plan 'no_plan'; use App::KGB::Change; use App::KGB::Client::Git; use App::KGB::Client::ServerRef; use Git; use File::Temp qw(tempdir); use File::Spec; use utf8; my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; my $tmp_cleanup = not $ENV{TEST_KEEP_TMP}; my $dir = tempdir( 'kgb-XXXXXXX', CLEANUP => $tmp_cleanup, DIR => File::Spec->tmpdir ); diag "Temp directory $dir will pe kept" unless $tmp_cleanup; sub write_tmp { my( $fn, $content ) = @_; open my $fh, '>', "$dir/$fn"; print $fh $content; close $fh; } if ( $ENV{TEST_KGB_BOT_DUMP} ) { diag "$ENV{TEST_KGB_BOT_DUMP} will be checked for IRC dump"; truncate( $ENV{TEST_KGB_BOT_DUMP}, 0 ) if -e $ENV{TEST_KGB_BOT_DUMP}; require Test::Differences; Test::Differences->import; } my $dump_fh; sub is_irc_output { return unless my $dump = $ENV{TEST_KGB_BOT_DUMP}; my $wanted = shift; use IO::File; $dump_fh ||= IO::File->new("< $dump") or die "Unable to open $dump: $!"; $dump_fh->binmode(':utf8'); local $/ = undef; $dump_fh->seek( $dump_fh->tell, 0 ); eq_or_diff( "" . <$dump_fh>, $wanted ); } my $remote = "$dir/there.git"; my $local = "$dir/here"; sub w { my ( $fn, $content ) = @_; write_tmp( "here/$fn", "$content\n" ); } sub a { my ( $fn, $content ) = @_; open my $fh, '>>', "$local/$fn"; print $fh $content, "\n"; close $fh; } mkdir $remote; $ENV{GIT_DIR} = $remote; system 'git', 'init', '--bare'; use Cwd; my $R = getcwd; my $hook_log; if ( $ENV{TEST_KGB_BOT_RUNNING} or $ENV{TEST_KGB_BOT_DUMP} ) { diag "will try to send notifications to locally running bot"; $hook_log = "$dir/hook.log"; write_tmp 'there.git/hooks/post-receive', <<"EOF"; #!/bin/sh tee -a "$dir/reflog" | PERL5LIB=$R/lib $R/script/kgb-client --repository git --git-reflog - --conf $R/eg/test-client.conf --status-dir $dir >> $hook_log 2>&1 EOF } else { write_tmp 'there.git/hooks/post-receive', <<"EOF"; #!/bin/sh cat >> "$dir/reflog" EOF } chmod 0755, "$dir/there.git/hooks/post-receive"; mkdir $local; $ENV{GIT_DIR} = "$local/.git"; mkdir "$local/.git"; system 'git', 'init'; my $git = 'Git'->repository($local); ok( $git, 'local repository allocated' ); isa_ok( $git, 'Git' ); $git->command( 'config', 'user.name', 'Test U. Ser' ); $git->command( 'config', 'user.email', 'ser@example.neverland' ); write_tmp 'reflog', ''; my $c = new_ok( 'App::KGB::Client::Git' => [ { repo_id => 'test', servers => [ App::KGB::Client::ServerRef->new( { uri => "http://127.0.0.1:1234/", password => "hidden", # not used by this client instance } ), ], #br_mod_re => \@br_mod_re, #br_mod_re_swap => $br_mod_re_swap, #ignore_branch => $ignore_branch, git_dir => $remote, reflog => "$dir/reflog", } ] ); sub push_ok { write_tmp 'reflog', ''; unlink $hook_log if $hook_log and -s $hook_log; my $ignore = $git->command( [qw( push origin --all )], { STDERR => 0 } ); $ignore = $git->command( [qw( push origin --tags )], { STDERR => 0 } ); $c->_parse_reflog; $c->_detect_commits; diag `cat $hook_log` if $hook_log and -s $hook_log; } my %commits; sub do_commit { $git->command_oneline( 'commit', '-m', shift ) =~ /\[(\w+).*\s+(\w+)\]/; push @{ $commits{$1} }, $2; diag "commit $2 in branch $1" unless $tmp_cleanup; } my $commit; ###### first commit w( 'old', 'content' ); $git->command( 'add', '.' ); do_commit('import old content'); $git->command( 'remote', 'add', 'origin', "file://$remote" ); push_ok; $commit = $c->describe_commit; ok( defined($commit), 'initial import commit' ); is( $c->describe_commit, undef, 'no more commits' ); #### branch, two changes, merge. then the changes should be reported only once my $b1 = 'a-new'; $git->command( [ 'checkout', '-b', $b1, 'master' ], { STDERR => 0 } ); w( 'new', 'content' ); $git->command( 'add', 'new' ); $git->command( 'commit', '-m', 'created new content' ); w( 'new', 'more content' ); $git->command( 'commit', '-a', '-m', 'updated new content' ); $git->command( 'checkout', '-q', 'master' ); $git->command( 'merge', '--no-ff', '-m', "merge '$b1' into master", $b1 ); # same with a branch name sorting after 'master' my $b2 = 'new-content'; $git->command( [ 'checkout', '-b', $b2, 'master' ], { STDERR => 0 } ); w( 'new', 'content' ); $git->command( 'add', 'new' ); $git->command( 'commit', '-m', 'created new content' ); w( 'new', 'more content' ); $git->command( 'commit', '-a', '-m', 'updated new content' ); $git->command( 'checkout', '-q', 'master' ); $git->command( 'merge', '--no-ff', '-m', "merge '$b2' into master", $b2 ); push_ok(); $commit = $c->describe_commit; ok( defined($commit), 'merge commit exists' ); is( $commit->branch, 'master' ); is( $commit->log, "merge '$b1' into master" ); $commit = $c->describe_commit; ok( defined($commit), 'merge commit exists' ); is( $commit->branch, 'master' ); is( $commit->log, "merge '$b2' into master" ); $commit = $c->describe_commit; ok( defined($commit), "first $b1 commit exists" ); is( $commit->branch, $b1 ); is( $commit->log, "created new content" ); $commit = $c->describe_commit; ok( defined($commit), "second $b1 commit exists" ); is( $commit->branch, $b1 ); is( $commit->log, "updated new content" ); $commit = $c->describe_commit; ok( defined($commit), "first $b2 commit exists" ); is( $commit->branch, $b2 ); is( $commit->log, "created new content" ); $commit = $c->describe_commit; ok( defined($commit), "second $b2 commit exists" ); is( $commit->branch, $b2 ); is( $commit->log, "updated new content" ); ##### No more commits after the last $commit = $c->describe_commit; is( $commit, undef ); App-KGB-1.31/man7000755001750001750 012203520733 12103 5ustar00damdam000000000000App-KGB-1.31/man7/kgb-protocol.pod000444001750001750 1172112203520733 15370 0ustar00damdam000000000000# vim: ts=4:sw=4:et:ai:sts=4 # # KGB - an IRC bot helping collaboration # Copyright © 2012 Damyan Ivanov # # 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 2 of the License, 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. # =head1 NAME KGB_protocol - specification of the client-server communication protocol =head1 DESCRIPTION The protocol used by the KGB collaboration service is based on JSON-RPC (L). KGB service helps collaboration by relaying notifications about commits in a version control system to IRC. It consists of client, hooked to the version control system which sends information about changes to the server, and a server, listening for client's notifications and relaying them on configured IRC channels. =head1 AUTHENTICATION Message content is authenticated by using two HTTP headers. The B header must contain the project ID, as defined in server's configuration. The B header must contain a SHA1 hash (in hexadecimal notation) calculated over the shared secret, the project ID and the JSON-encoded message. Upon receiving the HTTP request the server calculates the hash using the supplied project ID, the server copy of the shared secret for that project and the content of the HTTP request. If the hash matches the one provided in the B header, the authentication succeeds and the request is processed. Otherwise an error is returned. =head1 METHODS =head2 commit_v4 I This method takes information about a single commit and relays it to IRC. I is a map with the members described below. Any additional members are ignored. =over =item B I A string identifying the commit in the version control system. Git (short) hash, Subversion revision number, this kind of thing. =item B I A string to prepend to the commit ID when displaying on IRC. C is particularly useful for Subversion repositories. =item B I A string representing the commit author. =item B I A string representing the commit branch. =item B I A string representing the commit module or sub-project. =item B I The commit message. =item B I List of changes files/directories in the commit. Each string is a path, optionaly prepended with C<(A)> for added paths, C<(M)> for modified paths and C<(D)> for deleted paths. If no prefix is given modification is assumed. An additional plus sign flags property changes (Specific to Subversion term), e.g. C<(M+)>. =item B I A map with additional parameters. Currently supported members are: =over =item B A URL with commit details (e.g. gitweb or viewvc). =item B A flag whether to use IRC notices instead of regular messages. =item B A flag whether to use colors when sending commit notifications. Defaults to 1. =back =back =head2 relay_message I This method takes only one string argument which is the message to relay to IRC. There are no restrictions or requirements to the message content, which is relayed verbatim to project's IRC channels. =head2 ERRORS =head3 Errors reported on HTTP level Authentication errors use HTTP code C<401>, while other errors -- bad or missing headers and problems with the JSON data use HTTP code C<400>. The error text is in the reason phrase of the HTTP status line (see RFC 2616, section 6.1). =head3 Errors reported on JSON-RPC level After successful authentication and decoding of the JSON request, all the errors are reported as mandated by the JSON-RPC specification. =head1 AUTHOR =over =item Damyan Ivanov L =back =head1 COPYRIGHT & LICENSE Copyright (C) 2012 Damyan Ivanov 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 2 of the License, 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. =cut App-KGB-1.31/man5000755001750001750 012203520733 12101 5ustar00damdam000000000000App-KGB-1.31/man5/kgb-client.conf.pod000444001750001750 1376312203520733 15737 0ustar00damdam000000000000# vim: ts=4:sw=4:et:ai:sts=4 # # KGB - an IRC bot helping collaboration # Copyright © 2012 Damyan Ivanov # # 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 2 of the License, 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. =head1 NAME kgb-client.conf -- KGB client configuration file =head1 DESCRIPTION L can be configured via command line options and/or via a configuration file (via the B<--conf> option). Most of the settings can use either way, with command line options overriding settings from the configuration file. The file format is YAML. Elaborate example configuration is at the end of this document. =head1 Server connection configuration =head2 repo-id Unique project identifier on the server. B. =head2 password Pass phrase string. Used together with B to authenticate the request to the servers. Per-server configuration overrides this setting. =head2 timeout Request timeout in seconds. Defaults to C<15>. =head2 servers A list of maps, describing the servers to try to send ntifications to. Each server map can have the following members: =over =item B The URI of the server. Something like C. =item B SOAP proxy to use. Mandatory if using SOAP protocol. Defaults to to the value of the B setting, with C appended. =item B Per-server pass phrase. Defaults to the global B setting. =item B Timeout of the request. Defaults to the global B setting. =back =head2 B Directory to store information about the last successfuly contacted server. If the request is soon after the last contact, the last server is tried first. This way related notifications tend to come out of the same server. =head1 Content configuration =head2 B A list of regular expressions. These are matched against the path of the modified files and should have two captures in them -- the first capture is for the branch and the second capture is for the module. This is useful with Subversion repositories where there is a single repository for the project, with all the modules and branches. =head2 B Same as B, but captures are in reverse order -- module first and branch second. =head2 B A name of a branch to ignore. All changes in that branch are sent without branch info. Useful if most of the branches are made in one branch (e.g. trunk, master). =head2 B URL containing information about the commit (e.g. gitweb, viewvcs). C<${commit}>, C<${branch}>, C<${module}> and C<${project}> in that string are substituted with the commit ID, the branch name, the module name and the project ID respectively. See L for examples. =head2 B The name of the URL shortening service to use. If given, the service is used to shorten the result of B substitution. See L for the list of available services. Note that B comes with an additional service called C, which is primarily useful for clients running on Debian's collaboration server, alioth. =head2 B Send only a single line of the commit message to the channel. Possible values: auto|force|off. =over =item B B<(default)> Uses single line notification if the commit log's second line is an empty string. Otherwise uses the whole commit log (as if set to B). =item B Uses only the first line of the commit log, ignoring the rest. =item B Uses the whole commit log, ignoring any empty lines. =back =head2 B If set to a true value will make the IRC bot use IRC C messages instead of the ordinary C messages. =head2 B If set to a false value will make the IRC bot use no color in the notifications. =head1 EXAMPLE CONFGURATION # vim: filetype=yaml --- repo-id: 'kgb' password: 'notknown' timeout: 7 status-dir: '/home/proj/kgb-client/status' module-and-branch-re: - '^/([^/]+)/(trunk|tags/(?:[^/]+))/' - '^/([^/]+)/branches/([^/]+)/' - '^/(website)/()' web-link: 'http://svn.debian.org/viewvc/${project}?view=revision&revision=${commit}' # web-link: 'http://anonscm.debian.org/gitweb/?p=${project}/${module}.git;a=commitdiff;h=${commit}' #short-url-service: 'Metamark' short-url-service: 'Debli' ignore-branch: 'trunk' use-irc-notices: 0 use-color: 1 servers: - uri: 'http://kgb.server.org:9418/' - uri: 'http://another.kgb.server.org:9418/' timeout: 3 password: 'notknowneither' =head1 SEE ALSO L, L, L, L, L =head1 AUTHOR =over =item Damyan Ivanov L =back =head1 COPYRIGHT & LICENSE Copyright (C) 2012, 2013 Damyan Ivanov 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 2 of the License, 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. =cut App-KGB-1.31/man5/kgb.conf.pod000444001750001750 1730212203520733 14454 0ustar00damdam000000000000# vim: ts=4:sw=4:et:ai:sts=4 # # KGB - an IRC bot helping collaboration # Copyright © 2012, 2013 Damyan Ivanov # # 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 2 of the License, 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. =head1 NAME kgb.conf -- KGB bot configuration file =head1 DESCRIPTION F is the main configuration file of the KGB bot. Its location is in F unless changed with the B<--conf> command line option. See L. The file format is YAML. Elaborate example configuration is at the end of this document. =head1 Settings =head2 soap A map with the following possible keys: =over =item B IP address to listen to. =item B Port to listen to. =item B SOAP service name. Defaults to C. =back =head2 pid_dir Directory to store PID file to. Defautls to F. =head2 include Path to file with additional configuration. May be a path to a directory, in which case all files in it ending with C<.conf> are loaded, in alphabetical order. =head2 min_protocol_version Minimum version of the protocol that will be supported by the server. Defaults to C<1>. Protocol version 0 has no authentication. =head2 queue_limit When messages are sent to IRC, there is certain rate limitting, which may prevent the message to be sent right away. In this case messages are enqueued, and this parameter configures the size of the queue. When the queue is full client requests are rejected. =head2 repositories A map with keys project names and values maps with project details: =over =item password Password used for authenticating all requests from this project. =item private If true, disables commit announces to 'broadcast' IRC channels. =back =head2 networks A map with keys network names and values map of network configuration, containing the following items: =over =item server IP address/hostname of the IRC server to connect to. =item port Port number to connect to. =item nick Bot's nick on the network. =item ircname The full name of the bot on the network. =item username The username presented to the network. =item password A password for the network. =item nickserv_password A password for Nick server identification. =item flood If defined to a true value, the built-in rate-limitting feature of the IRC component will be turned off. B: this may cause the bot to be kicked off the IRC network. Use only when you control both the bot and the IRC network (e.g. when testing). =back =head2 channels A list of channels. Each element is a map and represents the channel's configuration: =over =item name Channel name, e.g. C<#commits>. B. =item network Network name, as described in the B map. B. =item broadcast Enables broadcasting all commit notifications to this channel. =item repos A list of project names, as described in the B map. Mandatory unless broadcast is enabled. =item smart_answers Each channel can contain separate list of smart answers, see below. =back =head2 smart_answers A list of strings to be used as replies when the bot is addressed on IRC. =head2 smart_answers_polygen If set to a true value, L will be used to generate replies when the bot is addressed on IRC. =head2 debug Enables logging of additional diagnostic information. =head2 admins A list of IRC masks, used to determine if a given IRC nick is bot administrator. Note that currently these nicks have no additional power. =head2 colors A map of colors to be used when painting commit messages. The following keys are recognized: =over =item revision Commit ID. Default: none. =item path Changed path. Default: teal. Depending on the action performed to the path, additional coloring is made: =over =item addition Used for added paths. Default: green. =item modification Used for modified paths. Default: teal. =item deletion Used for deleted paths. Default: bold red. =item replacement Used for replaced paths (a Subversion concept). Default: brown. =item prop_change Used for paths with changed properties (a Subversion concept), combined with other colors depending on the action -- addition, modification or replacement. Default: underline. =back =item author Commit author. Default: green. =item branch Commit branch. Default: brown. =item module Project module. Default: purple. =item web URL to commit information. Default: silver. =item separator The separator before the commit log. Default: none. =back =head1 EXAMPLE CONFGURATION # vim: filetype=yaml --- soap: server_addr: 127.0.0.1 server_port: 9999 service_name: KGB queue_limit: 150 log_file: "/var/log/kgb-bot.log" include: "/etc/kgb-bot/kgb.conf.d" repositories: # just a name to identify it foo: # needs to be the same on the client password: supersecret # private repositories aren't announced to broadcast channels # private: yes # Some witty answer for people that talk to the bot #smart_answers: # - "I wont speak with you!" # - "Do not disturb!" # - "Leave me alone, I am buzy!" # Admins are allowed some special !commands (currently only !version) #admins: # - some!irc@mask # - some!other@host networks: freenode: nick: KGB ircname: KGB bot username: kgb password: ~ nickserv_password: ~ server: irc.freenode.net port: 6667 channels: # a broadcast channel - name: '#commits' network: freenode broadcast: yes # a channel, tied to one or several repositories - name: '#foo' network: freenode repos: - foo # Can also be set per-channel #smart_answers: # - "I'm in ur channel, watching ur commits!" # - "I am not listening" # - "Shut up! I am buzy watching you." pid_dir: /var/run/kgb-bot # anything less is rejected min_protocol_ver: 1 # default colors: colors: repository: bold revision: bold author: green branch: brown module: purple path: teal addition: green modification: teal deletion: "bold red" replacement: reverse prop_change: underline web: silver # you can combine them like "bold red" (ouch!) # available colors: black, navy, green, red, brown, purple, orange, yellow, # lime, teal, aqua, blue, fuchsia, gray, silver, white # available modifiers: bold underline reverse =head1 SEE ALSO L, L =head1 AUTHOR =over =item Damyan Ivanov L =back =head1 COPYRIGHT & LICENSE Copyright (C) 2012, 2013 Damyan Ivanov 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 2 of the License, 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. =cut App-KGB-1.31/script000755001750001750 012203520733 12545 5ustar00damdam000000000000App-KGB-1.31/script/kgb-bot000555001750001750 12567012203520733 14230 0ustar00damdam000000000000#!/usr/bin/perl use utf8; # vim: ts=4:sw=4:et:ai:sts=4 # # KGB - an IRC bot helping collaboration # Copyright © 2008 Martín Ferrari # Copyright © 2008,2009,2010,2011,2012,2013 Damyan Ivanov # Copyright © 2010 gregor herrmann # # 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 2 of the License, 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. =head1 NAME kgb-bot - an IRC bot helping collaborative work =head1 SYNOPSIS kgb-bot [--config I] [--foreground] [--simulate I] =head1 OPTIONS =over 4 =item --config I Specify configuration file to load. Default is F. =item --config-dir I Specify directory with configuration files to load. All files like F<*.conf> are loaded, in alphabetical order. Default is F. =item --foreground Do not detach from console, print log messages to STDERR and do not become a daemon, useful for debugging. =item --simulate I Do not connect to IRC. Instead, output each notification line to the given I, like: #chan repo user branch revision module changed-paths #chan repo commit message line 1 #chan repo commit message line 2 There are no colour codes in the output, unless B<--simulate-color> is also given. =item --simulate-color Include color codes in the file used by B<--simulate>. =item --debug Log additional debugging information =back =cut package KGB; use strict; use warnings; use encoding 'utf8'; use open ':encoding(utf8)'; use App::KGB::Painter; use Time::Piece qw(localtime); our $VERSION = '1.31'; use Cwd; our $config; our ( $config_file, $config_dir, $foreground, $debug ); our %const = ( SOAPsvc => "SOAPServer", BAsvc => "BotAddressed", Connsvc => "Connecter", NSsvc => "NickServID", NRsvc => "NickReclaim", AJsvc => "AutoJoin", ); our %supported_protos = ( "0" => 1, "1" => 1, "2" => 1, "3" => 1, ); our $progname; our $restart = 0; our $shuttingdown = 0; our $painter; sub save_progname () { $progname = Cwd::realpath($0); } sub polygen_available () { unless ( eval { require IPC::Run } ) { KGB->debug("error loading IPC::Run\n"); KGB->debug($@); return undef; } unless ( eval { require File::Which } ) { KGB->debug("error loading File::Which\n"); KGB->debug($@); return undef; } my $oldpath = $ENV{PATH}; $ENV{PATH}='/usr/bin/:/usr/games'; my $polygen; unless ( $polygen = File::Which::which('polygen') ) { KGB->debug("missing polygen binary\n"); } $ENV{PATH} = $oldpath; return $polygen; } sub merge_conf_hash($$); sub merge_conf_hash($$) { my ( $dst, $src ) = @_; while ( my ($k, $v) = each %$src ) { if ( ref($v) ) { if ( exists $dst->{$k} ) { die "Error merging key '$k': source is a reference, but destination is scalar\n" unless ref( $dst->{$k} ); ref( $dst->{$k} ) eq ref($v) or die "Error merging key '$k': reference type mismatch\n"; if ( ref($v) eq 'ARRAY' ) { push @{ $dst->{$k} }, @$v; } elsif ( ref($v) eq 'HASH' ) { merge_conf_hash( $dst->{$k}, $v ); } else { die "Error merging key '$k': unknown reference type\n"; } } else { $dst->{$k} = $v; } } else { die "Error merging key '$k': source is scalar, but destination is not\n" if exists $dst->{$k} and ref( $dst->{$k} ); $dst->{$k} = $v; } } } sub parse_conf_file($;$); sub parse_conf_file($;$) { my $src = shift; my $met = shift // {}; return {} if $met->{$src}++; my $conf = {}; KGB->debug("Loading '$src."); if ( -d $src ) { -r _ or die "'$src' is not readable\n"; -x _ or die "'$src' is not usable (missing execute permission)\n"; for ( sort <$src/*.conf> ) { my $c = parse_conf_file($_); eval { merge_conf_hash( $conf, $c ); 1 } or die "Error loading $_: $@"; } } elsif ( -e $src ) { die "$src is world-readable\n" if ( stat($src) )[2] & 04; $conf = YAML::LoadFile($src) or die "Error loading config from $src\n"; } else { die "'$src' does not exist\n"; } if ( exists $conf->{include} ) { my $inc = $conf->{include}; my @inc; if (ref($inc)) { die "'include' should be scalar or list\n" unless ref($inc) eq 'ARRAY'; push @inc, @$inc; } else { push @inc, $inc; } for my $f ( @inc ) { my $c = parse_conf_file( $f, $met ); eval { merge_conf_hash( $conf, $c ); 1 } or die "Error loading $f: $@"; } } return $conf; } sub read_conf ($) { my $file = shift; my $conf = {}; $conf = parse_conf_file($file) if -e $file; die "Invalid or missing config key: soap" unless ( ref $conf->{soap} and ref $conf->{soap} eq "HASH" ); die "Invalid or missing config key: repositories" unless ( ref $conf->{repositories} and ref $conf->{repositories} eq "HASH" ); die "Invalid or missing config key: networks" unless ( ref $conf->{networks} and ref $conf->{networks} eq "HASH" ); die "Invalid or missing config key: channels" unless ( ref $conf->{channels} and ref $conf->{channels} eq "ARRAY" ); $conf->{soap}{service_name} ||= "KGB"; $conf->{soap}{server_port} ||= 5391; $conf->{soap}{server_addr} ||= "127.0.0.1"; if ( my $queue_limit = ( $conf->{queue_limit} //= 150 ) ) { $queue_limit =~ /^\d{1,10}$/ or die "Invalid value for config key 'queue_limit' ($queue_limit)"; } $conf->{min_protocol_ver} = 1 unless ( defined $conf->{min_protocol_ver} ); $conf->{smart_answers} ||= ["My master told me to not respond."]; $conf->{admins} //= []; ref( $conf->{admins} ) and ref( $conf->{admins} ) eq 'ARRAY' or die "Invalid config key: 'admins'. Must be an array"; unless ( $KGB::supported_protos{ $conf->{min_protocol_ver} } ) { die("Unrecognised min_protocol_ver (", $conf->{min_protocol_ver}, "). I only know about protocols ", join( ", ", keys %KGB::supported_protos ), ".\n" ); } foreach ( keys %{ $conf->{networks} } ) { $conf->{networks}{$_}{nick} ||= "KGB"; $conf->{networks}{$_}{ircname} ||= "KGB bot"; $conf->{networks}{$_}{username} ||= "kgb"; $conf->{networks}{$_}{port} ||= 6667; die "Missing server name in network $_\n" unless $conf->{networks}{$_}{server}; } $conf->{broadcast_channels} = []; $_->{channels} //= [] for values %{ $conf->{repositories} }; foreach ( @{ $conf->{channels} } ) { $_->{repositories} //= []; die "Missing channel name at channel\n" unless ( $_->{name} ); die "Invalid network at channel " . $_->{name} . "\n" unless ( $_->{network} and $conf->{networks}{ $_->{network} } ); push @{ $conf->{networks}{ $_->{network} }{channels} }, $_->{name}; die "Invalid repos key at channel " . $_->{name} . "\n" unless $_->{broadcast} or ( ref $_->{repos} and ref $_->{repos} eq "ARRAY" ); if ( $_->{broadcast} ) { push @{ $conf->{broadcast_channels} }, $_->{name}; KGB->out("Repository list ignored for broadcast channel $_->{name}\n") if @{ $_->{repositories} }; } else { KGB->out("Channel " . $_->{name} . " doesn't listen on any repository\n") unless @{ $_->{repos} }; foreach my $repo ( @{ $_->{repos} } ) { die "Invalid repository $repo at channel " . $_->{name} . "\n" unless ( $conf->{repositories}{$repo} ); push @{ $conf->{repositories}{$repo}{channels} }, $_->{name}; } } } my %chanidx = map ( { $conf->{channels}[$_]{name} => $conf->{channels}[$_] } 0 .. $#{ $conf->{channels} } ); $conf->{chanidx} = \%chanidx; $conf->{colors} ||= {}; $conf->{colors}{revision} //= ''; $conf->{colors}{path} //= 'teal'; $conf->{colors}{author} //= 'green'; $conf->{colors}{branch} //= 'brown'; $conf->{colors}{module} //= 'purple'; $conf->{colors}{web} //= 'silver'; $conf->{colors}{separator} //= ''; $conf->{colors}{addition} //= 'green'; $conf->{colors}{modification} //= 'teal'; $conf->{colors}{deletion} //= 'bold red'; $conf->{colors}{replacement} //= 'brown'; $conf->{colors}{prop_change} //= 'underline'; $KGB::debug = $conf->{debug} if exists $conf->{debug}; $conf->{pid_dir} //= '/var/run/kgb-bot'; KGB->debug( JSON::XS::encode_json($conf) ); return $conf; } sub load_conf($) { my $file = shift; my $conf = read_conf($file); # Save globals $config_file = Cwd::realpath($file); $config = $conf; return $conf; } sub reload_conf() { my $new_conf = eval { KGB::read_conf($config_file) }; if ($@) { KGB->out("Error in configuration file: $@"); return -1; } if ( $new_conf->{soap}{service_name} ne $config->{soap}{service_name} or $new_conf->{soap}{server_port} ne $config->{soap}{server_port} or $new_conf->{soap}{server_addr} ne $config->{soap}{server_addr} ) { KGB->out("Cannot reload configuration file, restarting\n"); return -2; # need restart } $painter = App::KGB::Painter->new( { styles => $new_conf->{colors} } ); KGB->out("Configuration file reloaded\n"); $config = $new_conf; return 0; } sub out { shift; print $KGB::out localtime->strftime('%Y.%m.%d %H:%M:%S').': ', @_, ( $_[-1] =~ /\n$/s ) ? () : "\n"; } sub debug { return unless $KGB::debug; shift->out( @_ ); } sub open_log { if ( my $f = $KGB::config->{log_file} ) { open( STDOUT, ">>", $f ) or die "Error opening log $f: $!\n"; open( STDERR, ">>", $f ) or die "Error opening log $f: $!\n"; } else { open( STDOUT, ">", "/dev/null" ) or die "Error closing stdout: $!\n"; open( STDERR, ">", "/dev/null" ) or die "Error closing stderr: $!\n"; } } package KGB::POE; use strict; use warnings; use POE; sub _start { my $kernel = $_[KERNEL]; my $session = $_[SESSION]; my $heap = $_[HEAP]; $kernel->sig( INT => 'sighandler' ); $kernel->sig( TERM => 'sighandler' ); $kernel->sig( QUIT => 'restarthandler' ); $kernel->sig( HUP => 'reloadhandler' ); $kernel->alias_set( $KGB::config->{soap}{service_name} ); $kernel->post( SOAPServer => 'ADDMETHOD', $KGB::config->{soap}{service_name}, 'commit', $KGB::config->{soap}{service_name}, 'commit', ); $kernel->yield("_irc_reconnect") unless $KGB::simulate; KGB->out( "Listening on http://", $KGB::config->{soap}{server_addr}, ":", $KGB::config->{soap}{server_port}, "?session=", $KGB::config->{soap}{service_name}, "\n" ); undef; } sub _stop { my $kernel = $_[KERNEL]; my $session = $_[SESSION]->ID(); KGB->out("_stop \@session $session\n"); $kernel->post( SOAPServer => 'DELSERVICE', $KGB::config->{soap}{service_name} ); } sub sighandler { my ( $kernel, $sig ) = ( $_[KERNEL], $_[ARG0] ); if ($KGB::shuttingdown) { die "Dying forcefully...\n"; } KGB->out("Deadly signal $sig received, exiting...\n"); $kernel->sig_handled(); $kernel->signal( $kernel => 'POCOIRC_SHUTDOWN', "KGB going to drink vodka" ); $kernel->post( SOAPServer => 'STOPLISTEN' ); %{ $_[HEAP] } = (); $KGB::shuttingdown = 1; undef; } sub restarthandler { my ( $kernel, $sig ) = ( $_[KERNEL], $_[ARG0] ); if ($KGB::shuttingdown) { die "Dying forcefully...\n"; } KGB->out("Signal $sig received, restarting...\n"); $kernel->sig_handled(); $KGB::restart = 1; $KGB::shuttingdown = 1; $kernel->signal( $kernel => 'POCOIRC_SHUTDOWN', "KGB restartink" ); $kernel->post( SOAPServer => 'STOPLISTEN' ); %{ $_[HEAP] } = (); undef; } sub reloadhandler { my ( $kernel, $sig ) = ( $_[KERNEL], $_[ARG0] ); KGB->out("Signal $sig received, reloading...\n"); $kernel->sig_handled(); my $ret = KGB::reload_conf(); if ( $ret == -1 ) { # error in config file return undef; } elsif ( $ret == -2 ) { # needs reload KGB->out("Forcing restart\n"); $KGB::restart = 1; $KGB::shuttingdown = 1; $kernel->signal( $kernel => 'POCOIRC_SHUTDOWN', "KGB restartink" ); $kernel->post( SOAPServer => 'STOPLISTEN' ); %{ $_[HEAP] } = (); return undef; } # reopen log file # we catch any exceptions, because we don't want reloading to be able # to kill the server unless ($KGB::foreground) { KGB->out("Error re-openning logs: $@\n") unless eval { KGB::open_log(); 1 }; } # Reload successful $kernel->yield("_irc_reconnect"); undef; } package KGB::SOAP; use strict; use warnings; use POE; use List::Util qw(max); use Digest::SHA qw(sha1_hex); use File::Basename; use App::KGB::Change; use Error ':try'; sub colorize { my( $category, $text ) = @_; return $text if $KGB::simulate and not $KGB::simulate_color; return $KGB::painter->colorize( $category => $text ); } sub colorize_change { my $c = shift; return $KGB::painter->colorize_change($c); } sub do_commit_msg { my ($kernel, $repo_id, $data) = @_; my $rev_prefix = $data->{rev_prefix} // ''; my $commit_id = $data->{commit_id}; my $changes = $data->{changes}; my @log = split( /\n+/, $data->{commit_log} ); my $author = $data->{author} // ''; my $branch = $data->{branch} // ''; my $module = $data->{module} // ''; local $KGB::config->{colors} = {} if exists $data->{extra} and exists $data->{extra}{use_color} and not $data->{extra}{use_color}; my $repo = $KGB::config->{repositories}{$repo_id}; my @channels = @{ $repo->{channels} }; push @channels, @{ $KGB::config->{broadcast_channels} } unless $repo->{private}; throw Error::Simple("Repository $repo_id has no associated channels.\n") unless (@channels); my $path_string; my %dirs; my $changed_files = scalar(@$changes); my $MAGIC_MAX_FILES = 4; $_ = App::KGB::Change->new($_) for grep { defined($_) and $_ ne '' } @$changes; # convert to objects my $common_dir = App::KGB::Change->detect_common_dir($changes) // ''; my @info; push @info, colorize( author => $author ) if $author ne ''; push @info, colorize( branch => $branch ) if $branch ne ''; push @info, "$rev_prefix" . colorize( revision => $commit_id ) if defined $commit_id; push @info, colorize( module => $module ) if $module ne ''; push @info, colorize( path => "$common_dir/" ) if $common_dir ne ''; if ( $changed_files > $MAGIC_MAX_FILES ) { my %dirs; for my $c (@$changes) { my $dir = dirname( $c->path ); $dirs{$dir}++; } my $dirs = scalar( keys %dirs ); my $path_string = join( ' ', ( $dirs > 1 ) ? sprintf( "(%d files in %d dirs)", $changed_files, $dirs ) : sprintf( "(%d files)", $changed_files ) ); push @info, colorize( path => $path_string ); } else { push @info, join( ' ', map { colorize_change($_) } @$changes ) if @$changes; } my @string = join( ' ', @info ); my $web_string = defined( $data->{extra}{web_link} ) ? colorize( web => $data->{extra}{web_link} ) : undef; my $use_notices = $data->{extra}{use_irc_notices}; # one-line notifications result in: # user branch commit module changes log link # multi-line notifications look like: # user branch commit module changes link # log line 1 # log line 2 ... if ( 1 == @log and length($log[0]) <= 80 ) { $string[0] .= ' ' . colorize( separator => '*' ) . ' ' . $log[0]; } else { push @string, @log; } $string[0] .= ' ' . colorize( separator => '*' ) . ' ' . $web_string if defined($web_string); my @tmp; # Standard says 512 (minus \r\n), anyway that's further trimmed when # resending to clients because of prefix. # Let's trim on 400, to be safe my $MAGIC_MAX_LINE = ( 400 - length("PRIVMSG ") - max( map( length, @channels ) ) ); while ( $_ = shift @string ) { if ( length($_) > $MAGIC_MAX_LINE ) { push @tmp, substr( $_, 0, $MAGIC_MAX_LINE ); unshift @string, colorize( repository => $repo_id ) . substr( $_, $MAGIC_MAX_LINE ); } else { push @tmp, $_; } } @string = @tmp; foreach my $chan ( @channels ) { if ($KGB::simulate) { my $fh = IO::File->new(">> $KGB::simulate") or die "Error opening $KGB::simulate for writing: $!\n"; $fh->autoflush(1); $fh->binmode(':utf8'); for (@string) { $fh->print("$chan $_\n"); } $fh->close; } else { $kernel->yield( irc_notify => $chan => \@string, $use_notices ? 'notice' : 'privmsg' ); } } } sub do_commit_v0 { my ( $kernel, $repo_id, $passwd, $rev, $paths, $log, $author ) = @_; throw Error::Simple("Unknown repository '$repo_id'\n") unless $KGB::config->{repositories}{$repo_id}; throw Error::Simple("Invalid password for repository $repo_id\n") if $KGB::config->{repositories}{$repo_id}{password} and $KGB::config->{repositories}{$repo_id}{password} ne $passwd; do_commit_msg( $kernel, $repo_id, { rev_prefix => 'r', commit_id => $rev, changes => $paths, commit_log => $log, author => $author } ); } sub do_commit_v1 { my ($kernel, $repo_id, $checksum, $rev, $paths, $log, $author, $branch, $module ) = @_; # v1 is the same as v2, but has no rev_prefix parameter return do_commit_v2( $kernel, $repo_id, $checksum, 'r', $rev, $paths, $log, $author, $branch, $module ); } sub do_commit_v2 { my ($kernel, $repo_id, $checksum, $rev_prefix, $rev, $paths, $log, $author, $branch, $module, ) = @_; throw Error::Simple("Repository $repo_id is unknown\n") unless $KGB::config->{repositories}{$repo_id}; # Protocol v2 always uses UTF-8 utf8::decode($_) for ( $repo_id, $rev, @$paths, $log, $author, $branch, $module ); my $message = join( "", $repo_id, $rev // (), @$paths, $log, ( defined($author) ? $author : () ), ( defined($branch) ? $branch : () ), ( defined($module) ? $module : () ), $KGB::config->{repositories}{$repo_id}{password} ); utf8::encode($message); # Convert to byte-sequence throw Error::Simple("Authentication failed for repository $repo_id\n") if $KGB::config->{repositories}{$repo_id}{password} and sha1_hex($message) ne $checksum; do_commit_msg( $kernel, $repo_id, { rev_prefix => $rev_prefix, commit_id => $rev, changes => $paths, commit_log => $log, author => $author, branch => $branch, module => $module } ); } sub do_commit_v3 { my ( $kernel, $repo_id, $serialized, $checksum ) = @_; throw Error::Simple("Repository $repo_id is unknown\n") unless exists $KGB::config->{repositories}{$repo_id}; my $pwd = $KGB::config->{repositories}{$repo_id}{password}; throw Error::Simple("Authentication failed for repository $repo_id\n") if not defined($pwd) or sha1_hex( $repo_id, $serialized, $pwd ) ne $checksum; my $data; my $ok = eval { $data = Storable::thaw($serialized); 1 }; throw Error::Simple("Invalid serialized data\n") unless $ok; do_commit_msg( $kernel, $repo_id, $data ); } sub commit { my $kernel = $_[KERNEL]; my $response = $_[ARG0]; my $params = $response->soapbody(); my $result; try { $result = do_commit( $kernel, $params ); $response->content("OK"); $kernel->post( SOAPServer => 'DONE', $response ); } catch Error::Simple with { my $E = shift; KGB->out("$E"); $kernel->post( SOAPServer => 'FAULT', $response, 'Client.Arguments', "$E", ); } otherwise { my $E = shift; KGB->out("commit crashed: $E"); $kernel->post( SOAPServer => 'FAULT', $response, 'Server.Code', 'Internal Server Error' ); }; } sub do_commit { my ( $kernel, $params ) = @_; KGB->out( "commit: " . YAML::Dump($params) ) if $KGB::debug; throw Error::Simple("commit(params ...)\n") unless ref $params and ref $params eq "HASH" and $params->{Array} and ref $params->{Array} and ref $params->{Array} eq "ARRAY"; my $proto_ver; if ( @{ $params->{Array} } == 6 ) { $proto_ver = 0; } else { $proto_ver = shift @{ $params->{Array} }; } throw Error::Simple( sprintf( "Protocol version %s not welcomed\n", $proto_ver // '' ) ) unless defined($proto_ver) and $KGB::supported_protos{$proto_ver} and $proto_ver >= $KGB::config->{min_protocol_ver}; throw Error::Simple("Rate limit enforced\n") if $KGB::config->{queue_limit} and $KGB::IRC::irc_object and $KGB::config->{queue_limit} < $KGB::IRC::irc_object->send_queue; if ( $proto_ver == 0 ) { return do_commit_v0( $kernel, @{ $params->{Array} } ); } if ( $proto_ver == 1 ) { return do_commit_v1( $kernel, @{ $params->{Array} } ); } if ( $proto_ver == 2 ) { return do_commit_v2( $kernel, @{ $params->{Array} } ); } if ( $proto_ver == 3 ) { return do_commit_v3( $kernel, @{ $params->{Array} } ); } throw Error::Simple("Invalid protocol version ($proto_ver)\n"); } package KGB::IRC; use strict; use warnings; use Digest::MD5 qw(md5_hex); use POE; use POE::Component::IRC::Common qw( parse_user matches_mask ); use Schedule::RateLimiter; our %current = (); our $irc_object; our $autoresponse_limitter = Schedule::RateLimiter->new( iterations => 5, seconds => 30, block => 0 ); # Handles the connection, disconnection and real-time configuration changes WRT # IRC servers and channels sub _irc_reconnect { my ( $kernel, $session ) = @_[ KERNEL, SESSION ]; my ( @to_start, @to_stop, @to_restart ); foreach my $net ( keys %current ) { next unless ( defined( $current{$net} ) ); my ( $new, $old ) = ( $KGB::config->{networks}{$net}, $current{$net} ); if ( !$new ) { push @to_stop, $net; } elsif ($new->{nick} ne $old->{nick} or $new->{ircname} ne $old->{ircname} or $new->{username} ne $old->{username} or ( $new->{password} || "" ) ne ( $old->{password} || "" ) or ( $new->{nickserv_password} || "" ) ne ( $old->{nickserv_password} || "" ) or $new->{server} ne $old->{server} or $new->{port} ne $old->{port} ) { push @to_restart, $net; } else { my ( %newchan, %oldchan, %allchan ); %newchan = map( { $_ => 1 } @{ $new->{channels} } ); %oldchan = map( { $_ => 1 } @{ $old->{channels} } ); %allchan = ( %newchan, %oldchan ); foreach my $chan ( keys %allchan ) { if ( $newchan{$chan} and !$oldchan{$chan} ) { KGB->out("Joining $chan...\n"); $kernel->post( "irc_$net" => join => $chan ); } elsif ( !$newchan{$chan} and $oldchan{$chan} ) { KGB->out("Parting $chan...\n"); $kernel->post( "irc_$net" => part => $chan ); } } $current{$net} = $new; } } foreach ( keys %{ $KGB::config->{networks} } ) { if ( !$current{$_} ) { push @to_start, $_; } } foreach my $net (@to_start) { my $opts = $KGB::config->{networks}{$net}; $current{$net} = $opts; my $irc = POE::Component::IRC::State->spawn( Alias => "irc_$net" ); # No need to register, as it's done automatically now. If you register # twice, POE never exits } foreach ( @to_stop, @to_restart ) { KGB->out("Disconnecting from $_\n"); $kernel->post( "irc_$_" => "shutdown" ); delete $current{$_}; } if (@to_restart) { $kernel->delay( "_irc_reconnect", 3 ); } } sub irc_registered { my ( $kernel, $heap, $sender ) = @_[ KERNEL, HEAP, SENDER ]; $irc_object = $_[ARG0]; my $alias = $irc_object->session_alias(); $alias =~ s/^irc_//; my $opts = $KGB::config->{networks}{$alias}; $irc_object->plugin_add( $KGB::const{AJsvc}, POE::Component::IRC::Plugin::AutoJoin->new( Channels => $opts->{channels}, ) ) if ( $opts->{channels} ); $irc_object->plugin_add( $KGB::const{NSsvc}, POE::Component::IRC::Plugin::NickServID->new( Password => $opts->{nickserv_password}, ) ) if ( $opts->{nickserv_password} ); $irc_object->plugin_add( $KGB::const{NRsvc}, POE::Component::IRC::Plugin::NickReclaim->new() ); $irc_object->plugin_add( $KGB::const{Connsvc}, POE::Component::IRC::Plugin::Connector->new() ); $irc_object->plugin_add( $KGB::const{BAsvc}, POE::Component::IRC::Plugin::BotAddressed->new() ); $irc_object->plugin_add( 'CTCP' => POE::Component::IRC::Plugin::CTCP->new( version => "KGB v$KGB::VERSION", userinfo => "KGB v$KGB::VERSION", clientinfo => "VERSION USERINFO CLIENTINFO SOURCE", source => "http://alioth.debian.org/projects/kgb", ) ); $kernel->post( $sender => connect => { Server => $opts->{server}, Port => $opts->{port}, Nick => $opts->{nick}, Ircname => $opts->{ircname}, Username => $opts->{username}, Password => $opts->{password}, Flood => $opts->{flood}, } ); undef; } sub _default { return 0 unless $KGB::debug; my ( $event, $args ) = @_[ ARG0 .. $#_ ]; my $out = "$event "; foreach (@$args) { if ( ref($_) eq 'ARRAY' ) { $out .= "[" . join( ", ", @$_ ) . "] "; } elsif ( ref($_) eq 'HASH' ) { $out .= "{" . join( ", ", %$_ ) . "} "; } elsif ( defined $_ ) { $out .= "'$_' "; } else { $out .= "undef "; } } KGB->debug("$out\n"); return 0; } sub irc_public { my ( $kernel, $heap, $who, $where, $what ) = @_[ KERNEL, HEAP, ARG0, ARG1, ARG2 ]; my $nick = parse_user($who); my $chan = $where->[0]; $kernel->yield( irc_new_hash => $chan => $what ); KGB->debug( $chan . ':<' . $nick . '> ' . $what . "\n" ); undef; } sub get_net { my $obj = shift; ( my $net = $obj->get_heap()->session_alias() ) =~ s/^irc_//; return $net; } sub irc_001 { my ( $kernel, $sender ) = @_[ KERNEL, SENDER ]; my $net = get_net($sender); my $channels = $KGB::config->{networks}{$net}{channels}; # Get the component's object at any time by accessing the heap of # the SENDER KGB->out( "Connected to $net (", $sender->get_heap->server_name(), ")\n" ); KGB->out( "Joining @$channels...\n" ) if ($channels); undef; } sub get_polygen_joke { my ( $out, $err ); my $polygen = KGB::polygen_available(); return undef unless $polygen; my $grammar = 'manager'; my @polygen = ( $polygen, "/usr/share/polygen/eng/$grammar.grm" ); my $result = eval { IPC::Run::run( \@polygen, \undef, \$out, \$err ) }; if ($@) { KGB->debug( "Error while running " . join( ' ', @polygen ) . ": $@" ); return undef; } elsif ($result) { return $out; } else { KGB->debug( "Error while running " . join( ' ', @polygen ) . ": $err" ); return undef; } } sub get_smart_answer { my $chan = shift; # Channel config if ( $KGB::config->{chanidx}{$chan}{smart_answers_polygen} ) { my $polygen_joke = get_polygen_joke; return $polygen_joke if $polygen_joke; } my $smart_answers = $chan ? $KGB::config->{chanidx}{$chan}{smart_answers} : undef; return $smart_answers->[ ( int( rand( scalar(@$smart_answers) ) ) ) ] if $smart_answers; # Global config if ( $KGB::config->{smart_answers_polygen} ) { my $polygen_joke = get_polygen_joke; return $polygen_joke if $polygen_joke; } $smart_answers = $KGB::config->{smart_answers}; return $smart_answers->[ ( int( rand( scalar(@$smart_answers) ) ) ) ] if $smart_answers; return undef; } sub got_a_message { my ( $kernel, $sender, $who, $where, $what ) = @_; my $chan = $where ? $where->[0] : undef; # could be a private message my $net = get_net($sender); return undef if $who =~ /\.bot\./; # try to ignore bots unless ( $autoresponse_limitter->event() ) { KGB->out("Auto response rate-limit reached.\n"); return undef; } if ( $what =~ /^\!([a-z]+)$/ ) { $kernel->yield( irc_command => $1 => $who => $chan => $net ); } else { my $msg = get_smart_answer($chan); return undef unless ($msg); my $nick = parse_user($who); reply( $kernel, $net, $chan, $nick, $msg ); } } sub irc_bot_addressed { my ( $kernel, $sender, $who, $where, $what ) = @_[ KERNEL, SENDER, ARG0, ARG1, ARG2 ]; got_a_message( $kernel, $sender, $who, $where, $what ); } sub irc_msg { my ( $kernel, $sender, $who, $what ) = @_[ KERNEL, SENDER, ARG0, ARG2 ]; got_a_message( $kernel, $sender, $who, undef, $what ); } sub irc_new_hash { my ( $kernel, $heap, $chan, $str ) = @_[ KERNEL, HEAP, ARG0, ARG1 ]; my $hash = md5_hex( $chan, substr( $str, 0, 100 ) ); my $seen_idx = $heap->{seen_idx} ||= {}; my $seen_list = $heap->{seen_list} ||= []; my $idx = exists $seen_idx->{$hash} ? $seen_idx->{$hash} : undef; # if found, move to the top of the list if ( defined($idx) ) { my $hash = splice( @$seen_list, $idx, 1 ); $seen_idx->{ $seen_list->[$_] }++ for 0 .. ( $idx - 1 ); unshift @$seen_list, $hash; $seen_idx->{$hash} = 0; return undef; } # only keep last 100 hashes if ( scalar( @{ $heap->{seen_list} } ) == 100 ) { delete $seen_idx->{ pop @$seen_list }; } push @$seen_list, $hash; $seen_idx->{$hash} = $#$seen_list; } sub irc_notify { my ( $kernel, $heap, $chan, $str, $method ) = @_[ KERNEL, HEAP, ARG0, ARG1, ARG2 ]; $method ||= 'privmsg'; # put some hidden character to avoid addressing anyone my $safety = $KGB::painter->color_codes->{normal}; $_ = "$safety$_" for @$str; my $part = substr( $str->[0], 0, 100 ); utf8::encode($part); my $hash = md5_hex( $chan, $part ); if ( exists $heap->{seen_idx}{$hash} ) { KGB->debug("'$part' seen recently\n"); return undef; } my $alias = "irc_" . $KGB::config->{chanidx}{$chan}{network}; $kernel->post( $alias => $method => $chan => $_ ) foreach (@$str); if ( $KGB::debug ) { KGB->out("$alias/$chan > $_\n") foreach (@$str); } } sub reply { my ( $kernel, $net, $chan, $nick, $msg ) = @_; # put some hidden character to avoid addressing anyone my $safety = $KGB::painter->color_codes->{normal}; return $chan ? $kernel->post( "irc_$net" => privmsg => $chan => "$safety$nick: $msg" ) : $kernel->post( "irc_$net" => privmsg => $nick => "$safety$msg" ); } sub irc_command { my ( $kernel, $heap, $command, $who, $chan, $net ) = @_[ KERNEL, HEAP, ARG0 .. ARG3 ]; my $nick = parse_user($who); return reply( $kernel, $net, $chan, $nick, "You are not my master" ) unless grep { matches_mask( $_, $who ) } @{ $KGB::config->{admins} }; if ( $command eq 'version' ) { return reply( $kernel, $net, $chan, $nick, "Tried /CTCP " . $KGB::config->{networks}{$net}{nick} . " VERSION?" ); } else { return reply( $kernel, $net, $chan, $nick, "command '$command' is not known to me" ); } } package KGB::JSON; use JSON::XS; use POE; use Digest::SHA qw(sha1_hex); sub json_error { my ( $json, $resp, $error ) = @_; KGB->out($error); $resp->code(200); $resp->message('OK'); $resp->content( encode_json( { id => $json->{id} // 0, error => $error, result => undef } ) ); } sub http_error { my ( $resp, $error, $code ) = @_; KGB->out($error); $resp->code($code // 400); $resp->message($error); $resp->content(''); } sub json_request { my ( $req, $resp, $path ) = @_[ ARG0, ARG1, ARG2 ]; my ($repo_id, $auth); unless (defined( $repo_id = $req->header('X-KGB-Project') ) and defined( $auth = $req->header('X-KGB-Auth') ) ) { http_error( $resp, 'Invalid or missing X-KGB-Project or X-KGB-Auth headers' ); $_[KERNEL]->post( $_[SENDER], DONE => $resp ); return; } unless ( exists $KGB::config->{repositories}{$repo_id} ) { http_error( $resp, "Unknown project ($repo_id)" ); $_[KERNEL]->post( $_[SENDER], DONE => $resp ); return; } my $check = sha1_hex( $KGB::config->{repositories}{$repo_id}{password}, $repo_id, $req->content ); unless ( $check eq $auth ) { http_error( $resp, "[$repo_id] Authentication failed", 401 ); $_[KERNEL]->post( $_[SENDER], DONE => $resp ); return; } my $json; my $ok = eval { $json = decode_json( $req->content ); 1; }; unless ($ok) { http_error( $resp, "[$repo_id] Error decoding JSON request" ); $_[KERNEL]->post( $_[SENDER], DONE => $resp ); return; } unless (exists $json->{method} and defined $json->{method} and not ref( $json->{method} ) and length $json->{method} ) { json_error( $json, $resp, "[$repo_id] Request has no valid \"method\" member" ); $_[KERNEL]->post( $_[SENDER], DONE => $resp ); return; } unless (exists $json->{params} and defined $json->{params} and ref( $json->{params} ) and ref( $json->{params} ) eq 'ARRAY' and length $json->{params} ) { json_error( $json, $resp, "[$repo_id] Request has no valid \"params\" member" ); $_[KERNEL]->post( $_[SENDER], DONE => $resp ); return; } unless (exists $json->{id} and defined $json->{id} and not ref( $json->{id} ) and length $json->{id} ) { json_error( $json, $resp, "[$repo_id] Request has no valid \"id\" member" ); $_[KERNEL]->post( $_[SENDER], DONE => $resp ); return; } my $json_result; $ok = eval { $json_result = encode_json( { id => $json->{id} // 0, result => __PACKAGE__->handle_json_request( $_[KERNEL], $repo_id, $json ), error => undef } ); 1; }; unless ($ok) { KGB->out($@); json_error( $json, $resp, "[$repo_id] Internal server error" ); $_[KERNEL]->post( $_[SENDER], DONE => $resp ); return; } $resp->code(200); $resp->message('OK'); $resp->content($json_result); $_[KERNEL]->post( $_[SENDER], DONE => $resp ); return; } sub handle_json_request { my ( $self, $kernel, $repo_id, $req ) = @_; my $meth = "do_json_$req->{method}"; die "Unknown method '$req->{method}'" unless $self->can($meth); return $self->$meth( $kernel, $repo_id, @{ $req->{params} } ); } sub do_json_commit_v4 { my ( $self, $kernel, $repo_id, $data ) = @_; KGB::SOAP::do_commit_msg( $kernel, $repo_id, $data ); } sub do_json_relay_message { my ( $self, $kernel, $repo_id, $message, $opts ) = @_; $opts ||= {}; defined $repo_id or die "Missing repo_id argument\n"; exists $KGB::config->{repositories}{$repo_id} or die "Invalid repository '$repo_id'\n"; my $repo = $KGB::config->{repositories}{$repo_id}; my @channels = @{ $repo->{channels} }; die("Repository $repo_id has no associated channels.\n") unless @channels; my @messages; defined($message) or die "No message parameter"; if (ref($message) ) { ref($message) eq 'ARRAY' or die "Unsupported ref (" . ref($message) . ") for the message parameter"; for (@$message) { defined($_) and not ref($_) or die "Invalid message"; length($_) or die "Empty message"; } KGB->debug( sprintf( "Received a batch of %d messages\n", scalar(@$message) ) ); @messages = @$message; } else { length($message) or die "Empty message"; push @messages, $message; } die "Too much messages (rate limit overflow)" if $KGB::config->{queue_limit} and $KGB::IRC::irc_object and $KGB::config->{queue_limit} < ( $KGB::IRC::irc_object->send_queue + scalar(@messages) ); foreach my $msg (@messages) { foreach my $chan ( @channels ) { for my $line ( split( /\n/, $msg ) ) { if ($KGB::simulate) { my $fh = IO::File->new(">> $KGB::simulate") or die "Error opening $KGB::simulate for writing: $!\n"; $fh->autoflush(1); $fh->binmode(':utf8'); $fh->print("$chan $line\n"); $fh->close; } else { $kernel->yield( irc_notify => $chan => [$line], $opts->{use_irc_notices} ? 'notice' : 'privmsg' ); } } } } return 'OK'; } package main; use strict; use warnings; use POE; use POE::Component::Server::SOAP; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::IRC::Plugin::BotAddressed; use POE::Component::IRC::Plugin::Connector; use POE::Component::IRC::Plugin::NickReclaim; use POE::Component::IRC::Plugin::NickServID; use POE::Component::IRC::Plugin::CTCP; use Getopt::Long; use YAML (); use Proc::PID::File; KGB::save_progname(); $KGB::out = \*STDERR; binmode( $KGB::out, ':utf8' ); my $conf_file = '/etc/kgb-bot/kgb.conf'; my $conf_dir = '/etc/kgb-bot/kgb.conf.d'; $KGB::foreground = 0; $KGB::simulate = 0; $KGB::simulate_color = 0; $KGB::debug = 0; Getopt::Long::Configure("bundling"); GetOptions( 'c|config=s' => \$conf_file, 'cd|config-dir=s' => \$conf_dir, 'f|foreground' => \$KGB::foreground, 'simulate=s' => \$KGB::simulate, 'simulate-color!' => \$KGB::simulate_color, 'debug!' => \$KGB::debug, ) or die 'Invalid parameters'; @ARGV and die "No command line arguments supported\n"; KGB::load_conf($conf_file); use Cwd; $KGB::simulate = Cwd::realpath($KGB::simulate) if $KGB::simulate; $KGB::painter = App::KGB::Painter->new( { styles => $KGB::config->{colors} } ); unless ($KGB::foreground) { pipe IN, OUT or die "pipe: $!\n"; my $pid = fork(); die "Can't fork: $!" unless ( defined $pid ); if ($pid) { close OUT; my $r = join( "", ); close IN or die $!; if ( $r =~ /^OK$/ ) { exit 0; } else { die $r; } } else { $poe_kernel->has_forked; } close IN; eval { die "Already running\n" if ( Proc::PID::File->running( verify => 1, dir => $KGB::config->{pid_dir}, ) ); POSIX::setsid() or die "setsid: $!\n"; umask(0022); chdir("/") or die "chdir: $!\n"; open( STDIN, "<", "/dev/null" ) or die "Error closing stdin: $!\n"; KGB::open_log(); }; if ($@) { print OUT $@; exit 1; } else { print OUT "OK\n"; close OUT; } } POE::Component::Server::SOAP->new( ALIAS => $KGB::const{SOAPsvc}, ADDRESS => $KGB::config->{soap}{server_addr}, PORT => $KGB::config->{soap}{server_port}, # override PoCo::SOAP HANDLERS to plug json-rpc SIMPLEHTTP => { 'HANDLERS' => [ { 'DIR' => '^/json-rpc', 'SESSION' => $KGB::config->{soap}{service_name}, 'EVENT' => 'json_request', }, { 'DIR' => '.*', 'SESSION' => 'SOAPServer', 'EVENT' => 'Got_Request', }, ], }, ); POE::Session->create( package_states => [ "KGB::POE" => [ qw(_start _stop sighandler restarthandler reloadhandler) ], "KGB::IRC" => [ qw(_irc_reconnect irc_registered irc_001 irc_public irc_bot_addressed irc_new_hash irc_notify _default irc_command irc_msg), ], "KGB::SOAP" => [qw(commit)], 'KGB::JSON' => [qw(json_request)], ], # options => {trace => 1, debug => 1} ); $poe_kernel->run; if ($KGB::restart) { exec( $KGB::progname, '--foreground', '--config' => $KGB::config_file, $KGB::debug ? '--debug' : (), ) or die "couldn't re-exec: $!\ņ"; } exit 0; App-KGB-1.31/script/kgb-split-config000555001750001750 517312203520733 15775 0ustar00damdam000000000000#!/usr/bin/perl # vim: ts=4:sw=4:et:ai:sts=4 # # KGB - an IRC bot helping collaboration # Copyright © 2012 Damyan Ivanov # Copyright © 2012 gregor herrmann # # 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 2 of the License, 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. use strict; use warnings; use 5.010; use autodie; use YAML qw(LoadFile DumpFile); use File::Spec; no warnings 'once'; local $YAML::SortKeys = [qw(repositories channels)]; use warnings; my $file = '/etc/kgb-bot/kgb.conf'; my $dir = '/etc/kgb-bot/kgb.conf.d'; my $yaml = LoadFile($file); foreach my $repo ( keys %{ $yaml->{repositories} } ) { my $splitconfig = {}; $splitconfig->{repositories}->{$repo} = $yaml->{repositories}->{$repo}; foreach my $channel ( @{ $yaml->{channels} } ) { push @{ $splitconfig->{channels} }, $channel if grep { $_ eq $repo } @{ $channel->{repos} }; } my $outfile = File::Spec->catdir( $dir, "$repo.conf" ); DumpFile( $outfile, $splitconfig ); } __END__ =head1 NAME kgb-split-config - helper script for splitting out project configurations =head1 SYNOPSIS B =head1 DESCRIPTION B extracts project configurations from F and dumps them as separate files into F. =head1 COPYRIGHT AND LICENSE Copyright (C) 2012 Damyan Ivanov Copyright (C) 2012 gregor herrmann 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 2 of the License, 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. =cut App-KGB-1.31/script/kgb-add-project000555001750001750 1163212203520733 15610 0ustar00damdam000000000000#!/usr/bin/perl # vim: ts=4:sw=4:et:ai:sts=4 # # KGB - an IRC bot helping collaboration # Copyright © 2012 Damyan Ivanov # # 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 2 of the License, 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. use strict; use warnings; use autodie; use Getopt::Long; use Pod::Usage; use YAML qw(LoadFile DumpFile Bless); my $file = '/etc/kgb-bot/kgb.conf'; my $dir = '/etc/kgb-bot/kgb.conf.d'; my $net = 'oftc'; my $save = 0; GetOptions( 'file=s' => \$file, 'dir=s' => \$dir, 'net|network=s' => \$net, 'save|write!' => \$save, ) or pod2usage( { -verbose => 1 } ); @ARGV == 3 or pod2usage(); my $yaml = LoadFile($file); my $networks = $yaml->{networks}; if ( $dir and -d $dir ) { $yaml = {}; } my ( $prj, $chan, $pwd ) = @ARGV; $yaml->{repositories}{$prj}{password} = $pwd; unless ( $chan =~ /^[#&+]/ ) { warn "W: Prepending channel name with a hash sign.\n"; $chan = "#$chan"; } unless ( exists $networks->{$net} ) { warn "W: Network '$net' missing on configuration file.\n"; } push @{ $yaml->{channels} }, { name => $chan, network => $net, repos => [ $prj ] }; my $i; my %key_order = map( ( $_ => $i++ ), qw(soap queue_limit log_file pid_dir min_protocol_ver debug admins repositories networks channels smart_answers smart_answers_polygen colors) ); Bless($yaml)->keys( [ sort { ( $key_order{$a} // 999 ) <=> ( $key_order{$b} // 999 ) } keys %$yaml ] ); foreach ( @{ $yaml->{channels} } ) { Bless($_)->keys( [ sort { $a ne 'name' } keys %$_ ] ); } my $outfh = \*STDOUT; my ( $uid, $gid, $mode ); if ($save) { $uid = ( stat($file) )[4]; $gid = ( stat($file) )[5]; $mode = ( stat($file) )[2] & 07777; if ( $dir and -d $dir ) { $file = File::Spec->catdir($dir, "$prj.conf"); } umask(~$mode & 0777); open( $outfh, '>', $file ); } print $outfh YAML::Dump($yaml); if ($save) { chown $uid, $gid, $file; } __END__ =head1 NAME kgb-add-project - helper script for adding new projects to kgb-bot configuration file =head1 SYNOPSIS B [--file configfile] [--dir configdir] [--net|--networks ircnetwork] [--save|--write] project-id ircchannel password =head1 DESCRIPTION B allows one to add new projects to B's configuration file from the command line. It writes the new config to stdout unless I<--save|--write> is given. =head1 ARGUMENTS =over =item B<--file> configfile Optional. Defaults to F. =item B<--dir> configdir Optional. Defaults to F. Used for writing config snippets for projects with B<--save|--write>. =item B<--net|network> ircnetwork Optional. Defaults to B. Needs to be in the I section of the configuration file. =item B<--save|--write> Optional. Write new config back to file instead of stdout. =item B B to be added. =item B IRC channel where the new project sends its messages. If the channel doesn't start with a character denoting IRC channel (C<#&+>), then a hash sign is prepended. =item B Password for the new project. =back =head1 EXAMPLE B my-project \#projectchannel RudFiarced0 =head1 CAVEATS =over =item * B sorts the top-level sections of the configuration file in a fixed order and re-orders the subsections alphabetically. =item * The output of B does not contain the comments that were present in the source configuration file. =back =head1 SEE ALSO =over =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (C) 2012 Damyan Ivanov 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 2 of the License, 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. =cut App-KGB-1.31/script/kgb-client000555001750001750 4112712203520733 14674 0ustar00damdam000000000000#!/usr/bin/perl use utf8; require v5.10.0; use feature 'switch'; # vim: ts=4:sw=4:et:ai:sts=4 # # KGB - an IRC bot helping collaboration # Copyright © 2008 Martín Ferrari # Copyright © 2009, 2011, 2012 Damyan Ivanov # # 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 2 of the License, 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. use strict; use warnings; =head1 NAME kgb-client - relay commits to KGB servers =head1 SYNOPSIS =over =item B --conf I [I ...] =item B --uri I --password I --repo-id I --repository I --timeout I --single-line-commits I --use-irc-notices --web-link I