├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .mailmap ├── .perltidyrc ├── Build.PL ├── Changes ├── LICENSE ├── META.json ├── README.md ├── cpanfile ├── examples ├── chat-monitor.pl ├── chat.pl └── simple.pl ├── inc └── Module │ └── AutoInstall.pm ├── lib └── Mojo │ └── RabbitMQ │ ├── Client.pm │ └── Client │ ├── Channel.pm │ ├── Consumer.pm │ ├── LocalQueue.pm │ ├── Method.pm │ ├── Method │ └── Publish.pm │ └── Publisher.pm ├── minil.toml ├── share └── amqp0-9-1.stripped.extended.xml ├── t ├── base.t ├── localqueue.t ├── publisher.t ├── static.t ├── uri.t └── use.t └── xt ├── client.t ├── consumer.t ├── pod.t └── server.t /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | push: 4 | branches: [ master ] 5 | pull_request: 6 | branches: [ master ] 7 | workflow_dispatch: 8 | 9 | jobs: 10 | build: 11 | runs-on: ubuntu-latest 12 | strategy: 13 | matrix: 14 | perl-version: 15 | - '5.16' 16 | - '5.18' 17 | - '5.20' 18 | - '5.22' 19 | - '5.30' 20 | - '5.32' 21 | container: 22 | image: perl:${{ matrix.perl-version }} 23 | steps: 24 | - uses: actions/checkout@v2 25 | - name: Log perl version 26 | run: perl -V 27 | - name: Install Module::Build::Tiny 28 | run: cpanm --quiet --notest --skip-satisfied Module::Build::Tiny 29 | - name: Install deps 30 | run: cpanm -n --installdeps . 31 | - name: Build 32 | run: | 33 | perl Build.PL 34 | ./Build 35 | - name: Run tests 36 | run: ./Build test 37 | env: 38 | TEST_POD: 1 39 | HARNESS_VERBOSE: 1 40 | HARNESS_OPTIONS: j9 41 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.build/ 2 | /_build/ 3 | /Build 4 | /Build.bat 5 | /blib 6 | /Makefile 7 | /pm_to_blib 8 | 9 | /carton.lock 10 | /.carton/ 11 | /local/ 12 | 13 | nytprof.out 14 | nytprof/ 15 | 16 | cover_db/ 17 | 18 | *.bak 19 | *.old 20 | *~ 21 | *.swp 22 | *.o 23 | *.obj 24 | 25 | !LICENSE 26 | 27 | /_build_params 28 | 29 | MYMETA.* 30 | 31 | /Mojo-RabbitMQ-Client-* 32 | /.build 33 | !Build/ 34 | !META.json 35 | -------------------------------------------------------------------------------- /.mailmap: -------------------------------------------------------------------------------- 1 | Sebastian Podjasek 2 | -------------------------------------------------------------------------------- /.perltidyrc: -------------------------------------------------------------------------------- 1 | -pbp # Start with Perl Best Practices 2 | -nst 3 | -b 4 | -w # Show all warnings 5 | -iob # Ignore old breakpoints 6 | -l=79 # 79 characters per line 7 | -mbl=2 # No more than 2 blank lines 8 | -i=2 # Indentation is 2 columns 9 | -ci=2 # Continuation indentation is 2 columns 10 | -vt=0 # Less vertical tightness 11 | -pt=2 # High parenthesis tightness 12 | -bt=2 # High brace tightness 13 | -sbt=2 # High square bracket tightness 14 | -isbc # Don't indent comments without leading space 15 | -utf8 # assume UTF-8 source #supported @2015 08 15 16 | -------------------------------------------------------------------------------- /Build.PL: -------------------------------------------------------------------------------- 1 | # ========================================================================= 2 | # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. 3 | # DO NOT EDIT DIRECTLY. 4 | # ========================================================================= 5 | 6 | use 5.008_001; 7 | use strict; 8 | 9 | use Module::Build::Tiny 0.035; 10 | 11 | Build_PL(); 12 | 13 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | {{$NEXT}} 2 | 3 | 0.3.1 2019-08-20T20:45:53Z 4 | - Re-apply licensing note from #37 - now in proper place 5 | 0.3.0 2019-08-20T20:35:39Z 6 | - Allow EXTERNAL as well as AMQPLAIN auth #35 (@AdamWill) 7 | - fixes legal issues with AMQP specs licensing #37 8 | 0.2.4 2019-08-20T00:49:27Z 9 | - Prevent warning about undefined object on closed channels #36 (@okurz) 10 | 0.2.3 2019-07-24T21:06:16Z 11 | - Clarified documentation #33, #34 (@AdamWill) 12 | 0.2.2 2019-05-23T11:20:22Z 13 | - Minor documentation fixes #32 (@sjn) 14 | - fix around 30 memory leaks #31 (@kraih) 15 | 0.2.1 2018-07-29T14:17:43Z 16 | - Fixed POD syntax, spelling & grammar errors #27,#28 (@gregoa) 17 | - Fixed POD error #26 (@manwar) 18 | 0.2.0 2018-07-25T13:23:26Z 19 | - Remove internal frame buffer handling, use Net::AMQP #11 (@kraih) 20 | 0.1.0 2018-02-16T10:15:32Z 21 | - Make Mojo::RabbitMQ::Client::Consumer use promises #23 (@christopherraa) 22 | - Fix circular includes by #20 (@christopherraa) 23 | - Start implementing Mojo::Promise, drop support for Mojolicious <7.53 24 | - Implement DEBUG on Client as suggested in #11 25 | - Fix early success event from ->publish #16 26 | - Fix query parameter naming in Publisher 27 | - Fix missing imports in Publisher #15 28 | - Fix #14 29 | - Implement Publisher API #5 30 | 0.0.9 2017-02-18T11:07:56Z 31 | - Proper implementation of URI parser PR#8 & #9 32 | - Support for query parameter with aliases 33 | - Add max_channels attribute to force maximum number of channels active 34 | - Additional developer test for quick consumer 35 | - Documentation changes 36 | 0.0.8 2017-01-30T12:13:18Z 37 | - Fix issues with UTF-8 data corruption on SSL sockets PR#7 38 | - Drop List::MoreUtils `none` in favour of core List::Util PR#4 39 | 0.0.7 2016-12-02T20:52:17Z 40 | - Fix missing dependencies 41 | 0.0.6 2016-11-24T00:45:01Z 42 | - First CPAN release 43 | 0.0.5 2016-11-23 44 | - First Minilla release 45 | - Drop support for Module::Install 46 | 0.0.4 2016-11-23 47 | - Moved all utility packages to Mojo::RabbitMQ::Client::* namespace 48 | - Added shorthand static methods for consumer & publisher 49 | 0.0.3 2016-11-18 50 | - Draft specs for new Publisher API 51 | 0.0.2 2016-10-25 52 | - Change the way how channels are opened 53 | - Deprecate _open method for channels 54 | - Show proper project url in client_properties 55 | - Support connect url according to spec 56 | - Include Module::Install for cleaner use in Docker containers 57 | - Docs updates & cleanups 58 | 0.0.1 2015-06-29 59 | - Initial release. Most things work. 60 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Artistic License 2.0 2 | 3 | Copyright (c) 2015 InWay Open Source code 4 | 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | This license establishes the terms under which a given free software 11 | Package may be copied, modified, distributed, and/or redistributed. 12 | The intent is that the Copyright Holder maintains some artistic 13 | control over the development of that Package while still keeping the 14 | Package available as open source and free software. 15 | 16 | You are always permitted to make arrangements wholly outside of this 17 | license directly with the Copyright Holder of a given Package. If the 18 | terms of this license do not permit the full use that you propose to 19 | make of the Package, you should contact the Copyright Holder and seek 20 | a different licensing arrangement. 21 | 22 | Definitions 23 | 24 | "Copyright Holder" means the individual(s) or organization(s) 25 | named in the copyright notice for the entire Package. 26 | 27 | "Contributor" means any party that has contributed code or other 28 | material to the Package, in accordance with the Copyright Holder's 29 | procedures. 30 | 31 | "You" and "your" means any person who would like to copy, 32 | distribute, or modify the Package. 33 | 34 | "Package" means the collection of files distributed by the 35 | Copyright Holder, and derivatives of that collection and/or of 36 | those files. A given Package may consist of either the Standard 37 | Version, or a Modified Version. 38 | 39 | "Distribute" means providing a copy of the Package or making it 40 | accessible to anyone else, or in the case of a company or 41 | organization, to others outside of your company or organization. 42 | 43 | "Distributor Fee" means any fee that you charge for Distributing 44 | this Package or providing support for this Package to another 45 | party. It does not mean licensing fees. 46 | 47 | "Standard Version" refers to the Package if it has not been 48 | modified, or has been modified only in ways explicitly requested 49 | by the Copyright Holder. 50 | 51 | "Modified Version" means the Package, if it has been changed, and 52 | such changes were not explicitly requested by the Copyright 53 | Holder. 54 | 55 | "Original License" means this Artistic License as Distributed with 56 | the Standard Version of the Package, in its current version or as 57 | it may be modified by The Perl Foundation in the future. 58 | 59 | "Source" form means the source code, documentation source, and 60 | configuration files for the Package. 61 | 62 | "Compiled" form means the compiled bytecode, object code, binary, 63 | or any other form resulting from mechanical transformation or 64 | translation of the Source form. 65 | 66 | 67 | Permission for Use and Modification Without Distribution 68 | 69 | (1) You are permitted to use the Standard Version and create and use 70 | Modified Versions for any purpose without restriction, provided that 71 | you do not Distribute the Modified Version. 72 | 73 | 74 | Permissions for Redistribution of the Standard Version 75 | 76 | (2) You may Distribute verbatim copies of the Source form of the 77 | Standard Version of this Package in any medium without restriction, 78 | either gratis or for a Distributor Fee, provided that you duplicate 79 | all of the original copyright notices and associated disclaimers. At 80 | your discretion, such verbatim copies may or may not include a 81 | Compiled form of the Package. 82 | 83 | (3) You may apply any bug fixes, portability changes, and other 84 | modifications made available from the Copyright Holder. The resulting 85 | Package will still be considered the Standard Version, and as such 86 | will be subject to the Original License. 87 | 88 | 89 | Distribution of Modified Versions of the Package as Source 90 | 91 | (4) You may Distribute your Modified Version as Source (either gratis 92 | or for a Distributor Fee, and with or without a Compiled form of the 93 | Modified Version) provided that you clearly document how it differs 94 | from the Standard Version, including, but not limited to, documenting 95 | any non-standard features, executables, or modules, and provided that 96 | you do at least ONE of the following: 97 | 98 | (a) make the Modified Version available to the Copyright Holder 99 | of the Standard Version, under the Original License, so that the 100 | Copyright Holder may include your modifications in the Standard 101 | Version. 102 | 103 | (b) ensure that installation of your Modified Version does not 104 | prevent the user installing or running the Standard Version. In 105 | addition, the Modified Version must bear a name that is different 106 | from the name of the Standard Version. 107 | 108 | (c) allow anyone who receives a copy of the Modified Version to 109 | make the Source form of the Modified Version available to others 110 | under 111 | 112 | (i) the Original License or 113 | 114 | (ii) a license that permits the licensee to freely copy, 115 | modify and redistribute the Modified Version using the same 116 | licensing terms that apply to the copy that the licensee 117 | received, and requires that the Source form of the Modified 118 | Version, and of any works derived from it, be made freely 119 | available in that license fees are prohibited but Distributor 120 | Fees are allowed. 121 | 122 | 123 | Distribution of Compiled Forms of the Standard Version 124 | or Modified Versions without the Source 125 | 126 | (5) You may Distribute Compiled forms of the Standard Version without 127 | the Source, provided that you include complete instructions on how to 128 | get the Source of the Standard Version. Such instructions must be 129 | valid at the time of your distribution. If these instructions, at any 130 | time while you are carrying out such distribution, become invalid, you 131 | must provide new instructions on demand or cease further distribution. 132 | If you provide valid instructions or cease distribution within thirty 133 | days after you become aware that the instructions are invalid, then 134 | you do not forfeit any of your rights under this license. 135 | 136 | (6) You may Distribute a Modified Version in Compiled form without 137 | the Source, provided that you comply with Section 4 with respect to 138 | the Source of the Modified Version. 139 | 140 | 141 | Aggregating or Linking the Package 142 | 143 | (7) You may aggregate the Package (either the Standard Version or 144 | Modified Version) with other packages and Distribute the resulting 145 | aggregation provided that you do not charge a licensing fee for the 146 | Package. Distributor Fees are permitted, and licensing fees for other 147 | components in the aggregation are permitted. The terms of this license 148 | apply to the use and Distribution of the Standard or Modified Versions 149 | as included in the aggregation. 150 | 151 | (8) You are permitted to link Modified and Standard Versions with 152 | other works, to embed the Package in a larger work of your own, or to 153 | build stand-alone binary or bytecode versions of applications that 154 | include the Package, and Distribute the result without restriction, 155 | provided the result does not expose a direct interface to the Package. 156 | 157 | 158 | Items That are Not Considered Part of a Modified Version 159 | 160 | (9) Works (including, but not limited to, modules and scripts) that 161 | merely extend or make use of the Package, do not, by themselves, cause 162 | the Package to be a Modified Version. In addition, such works are not 163 | considered parts of the Package itself, and are not subject to the 164 | terms of this license. 165 | 166 | 167 | General Provisions 168 | 169 | (10) Any use, modification, and distribution of the Standard or 170 | Modified Versions is governed by this Artistic License. By using, 171 | modifying or distributing the Package, you accept this license. Do not 172 | use, modify, or distribute the Package, if you do not accept this 173 | license. 174 | 175 | (11) If your Modified Version has been derived from a Modified 176 | Version made by someone other than you, you are nevertheless required 177 | to ensure that your Modified Version complies with the requirements of 178 | this license. 179 | 180 | (12) This license does not grant you the right to use any trademark, 181 | service mark, tradename, or logo of the Copyright Holder. 182 | 183 | (13) This license includes the non-exclusive, worldwide, 184 | free-of-charge patent license to make, have made, use, offer to sell, 185 | sell, import and otherwise transfer the Package with respect to any 186 | patent claims licensable by the Copyright Holder that are necessarily 187 | infringed by the Package. If you institute patent litigation 188 | (including a cross-claim or counterclaim) against any party alleging 189 | that the Package constitutes direct or contributory patent 190 | infringement, then this Artistic License to you shall terminate on the 191 | date that such litigation is filed. 192 | 193 | (14) Disclaimer of Warranty: 194 | THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS 195 | IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED 196 | WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR 197 | NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL 198 | LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL 199 | BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 200 | DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF 201 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 202 | 203 | -------------------------------------------------------------------------------- /META.json: -------------------------------------------------------------------------------- 1 | { 2 | "abstract" : "Mojo::IOLoop based RabbitMQ client", 3 | "author" : [ 4 | "-2019, Sebastian Podjasek and others" 5 | ], 6 | "dynamic_config" : 0, 7 | "generated_by" : "Minilla/v3.0.14, CPAN::Meta::Converter version 2.150010", 8 | "license" : [ 9 | "artistic_2" 10 | ], 11 | "meta-spec" : { 12 | "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", 13 | "version" : 2 14 | }, 15 | "name" : "Mojo-RabbitMQ-Client", 16 | "no_index" : { 17 | "directory" : [ 18 | "t", 19 | "xt", 20 | "inc", 21 | "share", 22 | "eg", 23 | "examples", 24 | "author", 25 | "builder" 26 | ] 27 | }, 28 | "prereqs" : { 29 | "configure" : { 30 | "requires" : { 31 | "Module::Build::Tiny" : "0.035" 32 | } 33 | }, 34 | "develop" : { 35 | "requires" : { 36 | "Test::CPAN::Meta" : "0", 37 | "Test::MinimumVersion::Fast" : "0.04", 38 | "Test::PAUSE::Permissions" : "0.04", 39 | "Test::Pod" : "1.41", 40 | "Test::Spellunker" : "v0.2.7" 41 | } 42 | }, 43 | "runtime" : { 44 | "requires" : { 45 | "File::ShareDir" : "0", 46 | "List::Util" : "1.33", 47 | "Mojolicious" : "7.53", 48 | "Net::AMQP" : "0.06", 49 | "perl" : "5.010" 50 | } 51 | }, 52 | "test" : { 53 | "requires" : { 54 | "Test::Exception" : "0.43", 55 | "Test::More" : "0.98" 56 | } 57 | } 58 | }, 59 | "release_status" : "unstable", 60 | "resources" : { 61 | "bugtracker" : { 62 | "web" : "https://github.com/inway/mojo-rabbitmq-client/issues" 63 | }, 64 | "homepage" : "https://github.com/inway/mojo-rabbitmq-client", 65 | "repository" : { 66 | "type" : "git", 67 | "url" : "git://github.com/inway/mojo-rabbitmq-client.git", 68 | "web" : "https://github.com/inway/mojo-rabbitmq-client" 69 | } 70 | }, 71 | "version" : "0.3.1", 72 | "x_contributors" : [ 73 | "Adam Williamson ", 74 | "Adam Williamson ", 75 | "Christopher Rasch-Olsen Raa ", 76 | "Mohammad S Anwar ", 77 | "Oliver Kurz ", 78 | "Patrick Goldmann ", 79 | "Richard Lippmann ", 80 | "Salve J. Nilsen ", 81 | "Sebastian Podjasek ", 82 | "Sebastian Riedel ", 83 | "Stephan Kulow ", 84 | "Vidar Tyldum ", 85 | "gregor herrmann " 86 | ], 87 | "x_serialization_backend" : "JSON::PP version 2.97000" 88 | } 89 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![CI](https://github.com/inway/mojo-rabbitmq-client/actions/workflows/ci.yml/badge.svg)](https://github.com/inway/mojo-rabbitmq-client/actions/workflows/ci.yml) [![MetaCPAN Release](https://badge.fury.io/pl/Mojo-RabbitMQ-Client.svg)](https://metacpan.org/release/Mojo-RabbitMQ-Client) 2 | # NAME 3 | 4 | Mojo::RabbitMQ::Client - Mojo::IOLoop based RabbitMQ client 5 | 6 | # SYNOPSIS 7 | 8 | ```perl 9 | use Mojo::RabbitMQ::Client; 10 | 11 | # Supply URL according to (https://www.rabbitmq.com/uri-spec.html) 12 | my $client = Mojo::RabbitMQ::Client->new( 13 | url => 'amqp://guest:guest@127.0.0.1:5672/'); 14 | 15 | # Catch all client related errors 16 | $client->catch(sub { warn "Some error caught in client"; }); 17 | 18 | # When connection is in Open state, open new channel 19 | $client->on( 20 | open => sub { 21 | my ($client) = @_; 22 | 23 | # Create a new channel with auto-assigned id 24 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 25 | 26 | $channel->catch(sub { warn "Error on channel received"; }); 27 | 28 | $channel->on( 29 | open => sub { 30 | my ($channel) = @_; 31 | $channel->qos(prefetch_count => 1)->deliver; 32 | 33 | # Publish some example message to test_queue 34 | my $publish = $channel->publish( 35 | exchange => 'test', 36 | routing_key => 'test_queue', 37 | body => 'Test message', 38 | mandatory => 0, 39 | immediate => 0, 40 | header => {} 41 | ); 42 | # Deliver this message to server 43 | $publish->deliver; 44 | 45 | # Start consuming messages from test_queue 46 | my $consumer = $channel->consume(queue => 'test_queue'); 47 | $consumer->on(message => sub { say "Got a message" }); 48 | $consumer->deliver; 49 | } 50 | ); 51 | $channel->on(close => sub { $log->error('Channel closed') }); 52 | 53 | $client->open_channel($channel); 54 | } 55 | ); 56 | 57 | # Start connection 58 | $client->connect(); 59 | 60 | # Start Mojo::IOLoop if not running already 61 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 62 | ``` 63 | 64 | ## CONSUMER 65 | 66 | ```perl 67 | use Mojo::RabbitMQ::Client; 68 | my $consumer = Mojo::RabbitMQ::Client->consumer( 69 | url => 'amqp://guest:guest@127.0.0.1:5672/?exchange=mojo&queue=mojo', 70 | defaults => { 71 | qos => {prefetch_count => 1}, 72 | queue => {durable => 1}, 73 | consumer => {no_ack => 0}, 74 | } 75 | ); 76 | 77 | $consumer->catch(sub { die "Some error caught in Consumer" } ); 78 | $consumer->on('success' => sub { say "Consumer ready" }); 79 | $consumer->on( 80 | 'message' => sub { 81 | my ($consumer, $message) = @_; 82 | 83 | $consumer->channel->ack($message)->deliver; 84 | } 85 | ); 86 | $consumer->start(); 87 | 88 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 89 | ``` 90 | 91 | ## PUBLISHER 92 | 93 | ```perl 94 | use Mojo::RabbitMQ::Client; 95 | my $publisher = Mojo::RabbitMQ::Client->publisher( 96 | url => 'amqp://guest:guest@127.0.0.1:5672/?exchange=mojo&routing_key=mojo' 97 | ); 98 | 99 | $publisher->publish('plain text'); 100 | 101 | $publisher->publish( 102 | {encode => { to => 'json'}}, 103 | routing_key => 'mojo_mq' 104 | )->then(sub { 105 | say "Message published"; 106 | })->catch(sub { 107 | die "Publishing failed" 108 | })->wait; 109 | ``` 110 | 111 | # DESCRIPTION 112 | 113 | [Mojo::RabbitMQ::Client](https://metacpan.org/pod/Mojo::RabbitMQ::Client) is a rewrite of [AnyEvent::RabbitMQ](https://metacpan.org/pod/AnyEvent::RabbitMQ) to work on top of [Mojo::IOLoop](https://metacpan.org/pod/Mojo::IOLoop). 114 | 115 | # EVENTS 116 | 117 | [Mojo::RabbitMQ::Client](https://metacpan.org/pod/Mojo::RabbitMQ::Client) inherits all events from [Mojo::EventEmitter](https://metacpan.org/pod/Mojo::EventEmitter) and can emit the 118 | following new ones. 119 | 120 | ## connect 121 | 122 | ```perl 123 | $client->on(connect => sub { 124 | my ($client, $stream) = @_; 125 | ... 126 | }); 127 | ``` 128 | 129 | Emitted when TCP/IP connection with RabbitMQ server is established. 130 | 131 | ## open 132 | 133 | ```perl 134 | $client->on(open => sub { 135 | my ($client) = @_; 136 | ... 137 | }); 138 | ``` 139 | 140 | Emitted AMQP protocol Connection.Open-Ok method is received. 141 | 142 | ## close 143 | 144 | ```perl 145 | $client->on(close => sub { 146 | my ($client) = @_; 147 | ... 148 | }); 149 | ``` 150 | 151 | Emitted on reception of Connection.Close-Ok method. 152 | 153 | ## disconnect 154 | 155 | ```perl 156 | $client->on(disconnect => sub { 157 | my ($client) = @_; 158 | ... 159 | }); 160 | ``` 161 | 162 | Emitted when TCP/IP connection gets disconnected. 163 | 164 | # ATTRIBUTES 165 | 166 | [Mojo::RabbitMQ::Client](https://metacpan.org/pod/Mojo::RabbitMQ::Client) has following attributes. 167 | 168 | ## tls 169 | 170 | ```perl 171 | my $tls = $client->tls; 172 | $client = $client->tls(1) 173 | ``` 174 | 175 | Force secure connection. Default is disabled (`0`). 176 | 177 | ## user 178 | 179 | ```perl 180 | my $user = $client->user; 181 | $client = $client->user('guest') 182 | ``` 183 | 184 | Sets username for authorization, by default it's not defined. 185 | 186 | ## pass 187 | 188 | ```perl 189 | my $pass = $client->pass; 190 | $client = $client->pass('secret') 191 | ``` 192 | 193 | Sets user password for authorization, by default it's not defined. 194 | 195 | ## host 196 | 197 | ```perl 198 | my $host = $client->host; 199 | $client = $client->host('localhost') 200 | ``` 201 | 202 | Hostname or IP address of RabbitMQ server. Defaults to `localhost`. 203 | 204 | ## port 205 | 206 | ```perl 207 | my $port = $client->port; 208 | $client = $client->port(1234) 209 | ``` 210 | 211 | Port on which RabbitMQ server listens for new connections. 212 | Defaults to `5672`, which is standard RabbitMQ server listen port. 213 | 214 | ## vhost 215 | 216 | ```perl 217 | my $vhost = $client->vhost; 218 | $client = $client->vhost('/') 219 | ``` 220 | 221 | RabbitMQ virtual server to user. Default is `/`. 222 | 223 | ## params 224 | 225 | ```perl 226 | my $params = $client->params; 227 | $client = $client->params(Mojo::Parameters->new('verify=1')) 228 | ``` 229 | 230 | Sets additional parameters for connection. Default is not defined. 231 | 232 | For list of supported parameters see ["SUPPORTED QUERY PARAMETERS"](#supported-query-parameters). 233 | 234 | ## url 235 | 236 | ```perl 237 | my $url = $client->url; 238 | $client = $client->url('amqp://...'); 239 | ``` 240 | 241 | Sets all connection parameters in one string, according to specification from 242 | [https://www.rabbitmq.com/uri-spec.html](https://www.rabbitmq.com/uri-spec.html). 243 | 244 | ```perl 245 | amqp_URI = "amqp[s]://" amqp_authority [ "/" vhost ] [ "?" query ] 246 | 247 | amqp_authority = [ amqp_userinfo "@" ] host [ ":" port ] 248 | 249 | amqp_userinfo = username [ ":" password ] 250 | 251 | username = *( unreserved / pct-encoded / sub-delims ) 252 | 253 | password = *( unreserved / pct-encoded / sub-delims ) 254 | 255 | vhost = segment 256 | ``` 257 | 258 | ## heartbeat\_timeout 259 | 260 | ```perl 261 | my $timeout = $client->heartbeat_timeout; 262 | $client = $client->heartbeat_timeout(180); 263 | ``` 264 | 265 | Heartbeats are use to monitor peer reachability in AMQP. 266 | Default value is `60` seconds, if set to `0` no heartbeats will be sent. 267 | 268 | ## connect\_timeout 269 | 270 | ```perl 271 | my $timeout = $client->connect_timeout; 272 | $client = $client->connect_timeout(5); 273 | ``` 274 | 275 | Connection timeout used by [Mojo::IOLoop::Client](https://metacpan.org/pod/Mojo::IOLoop::Client). 276 | Defaults to environment variable `MOJO_CONNECT_TIMEOUT` or `10` seconds 277 | if nothing else is set. 278 | 279 | ## max\_channels 280 | 281 | ```perl 282 | my $max_channels = $client->max_channels; 283 | $client = $client->max_channels(10); 284 | ``` 285 | 286 | Maximum number of channels allowed to be active. Defaults to `0` which 287 | means no implicit limit. 288 | 289 | When you try to call `add_channel` over limit an `error` will be 290 | emitted on channel saying that: _Maximum number of channels reached_. 291 | 292 | # STATIC METHODS 293 | 294 | ## consumer 295 | 296 | ```perl 297 | my $client = Mojo::RabbitMQ::Client->consumer(...) 298 | ``` 299 | 300 | Shortcut for creating [Mojo::RabbitMQ::Client::Consumer](https://metacpan.org/pod/Mojo::RabbitMQ::Client::Consumer). 301 | 302 | ## publisher 303 | 304 | ```perl 305 | my $client = Mojo::RabbitMQ::Client->publisher(...) 306 | ``` 307 | 308 | Shortcut for creating [Mojo::RabbitMQ::Client::Publisher](https://metacpan.org/pod/Mojo::RabbitMQ::Client::Publisher). 309 | 310 | # METHODS 311 | 312 | [Mojo::RabbitMQ::Client](https://metacpan.org/pod/Mojo::RabbitMQ::Client) inherits all methods from [Mojo::EventEmitter](https://metacpan.org/pod/Mojo::EventEmitter) and implements 313 | the following new ones. 314 | 315 | ## connect 316 | 317 | ``` 318 | $client->connect(); 319 | ``` 320 | 321 | Tries to connect to RabbitMQ server and negotiate AMQP protocol. 322 | 323 | ## close 324 | 325 | ``` 326 | $client->close(); 327 | ``` 328 | 329 | ## param 330 | 331 | ```perl 332 | my $param = $client->param('name'); 333 | $client = $client->param(name => 'value'); 334 | ``` 335 | 336 | ## add\_channel 337 | 338 | ```perl 339 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 340 | ... 341 | $channel = $client->add_channel($channel); 342 | $channel->open; 343 | ``` 344 | 345 | ## open\_channel 346 | 347 | ```perl 348 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 349 | ... 350 | $client->open_channel($channel); 351 | ``` 352 | 353 | ## delete\_channel 354 | 355 | ```perl 356 | my $removed = $client->delete_channel($channel->id); 357 | ``` 358 | 359 | # SUPPORTED QUERY PARAMETERS 360 | 361 | There's no formal specification, nevertheless a list of common parameters 362 | recognized by officially supported RabbitMQ clients is maintained here: 363 | [https://www.rabbitmq.com/uri-query-parameters.html](https://www.rabbitmq.com/uri-query-parameters.html). 364 | 365 | Some shortcuts are also supported, you'll find them in parenthesis. 366 | 367 | Aliases are less significant, so when both are specified only primary 368 | value will be used. 369 | 370 | ## cacertfile (_ca_) 371 | 372 | Path to Certificate Authority file for TLS. 373 | 374 | ## certfile (_cert_) 375 | 376 | Path to the client certificate file for TLS. 377 | 378 | ## keyfile (_key_) 379 | 380 | Path to the client certificate private key file for TLS. 381 | 382 | ## fail\_if\_no\_peer\_cert (_verify_) 383 | 384 | TLS verification mode, defaults to 0x01 on the client-side if a certificate 385 | authority file has been provided, or 0x00 otherwise. 386 | 387 | ## auth\_mechanism 388 | 389 | Sets the AMQP authentication mechanism. Defaults to AMQPLAIN. AMQPLAIN and 390 | EXTERNAL are supported; EXTERNAL will only work if [Mojo::RabbitMQ::Client](https://metacpan.org/pod/Mojo::RabbitMQ::Client) does not need 391 | to do anything beyond passing along a username and password if specified. 392 | 393 | ## heartbeat 394 | 395 | Sets requested heartbeat timeout, just like `heartbeat_timeout` attribute. 396 | 397 | ## connection\_timeout (_timeout_) 398 | 399 | Sets connection timeout - see [connection\_timeout](https://metacpan.org/pod/connection_timeout) attribute. 400 | 401 | ## channel\_max 402 | 403 | Sets maximum number of channels - see [max\_channels](https://metacpan.org/pod/max_channels) attribute. 404 | 405 | # SEE ALSO 406 | 407 | [Mojo::RabbitMQ::Client::Channel](https://metacpan.org/pod/Mojo::RabbitMQ::Client::Channel), [Mojo::RabbitMQ::Client::Consumer](https://metacpan.org/pod/Mojo::RabbitMQ::Client::Consumer), [Mojo::RabbitMQ::Client::Publisher](https://metacpan.org/pod/Mojo::RabbitMQ::Client::Publisher) 408 | 409 | # COPYRIGHT AND LICENSE 410 | 411 | Copyright (C) 2015-2019, Sebastian Podjasek and others 412 | 413 | Based on [AnyEvent::RabbitMQ](https://metacpan.org/pod/AnyEvent::RabbitMQ) - Copyright (C) 2010 Masahito Ikuta, maintained by `bobtfish@bobtfish.net` 414 | 415 | This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. 416 | 417 | Contains AMQP specification (`shared/amqp0-9-1.stripped.extended.xml`) licensed under BSD-style license. 418 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires 'perl', '5.010'; 2 | requires 'Mojolicious', '7.53'; 3 | requires 'Net::AMQP', '0.06'; 4 | requires 'File::ShareDir'; 5 | requires 'List::Util', '1.33'; 6 | requires 'File::ShareDir'; 7 | 8 | on 'test' => sub { 9 | requires 'Test::More', '0.98'; 10 | requires 'Test::Exception', '0.43'; 11 | }; 12 | -------------------------------------------------------------------------------- /examples/chat-monitor.pl: -------------------------------------------------------------------------------- 1 | use Mojo::RabbitMQ::Client; 2 | 3 | $|++; 4 | 5 | my $amqp 6 | = Mojo::RabbitMQ::Client->new( 7 | url => ($ENV{MOJO_RABBITMQ_URL} || 'rabbitmq://guest:guest@127.0.0.1:5672/') 8 | ); 9 | $amqp->on( 10 | open => sub { 11 | my ($self) = @_; 12 | 13 | my $channel = Mojo::RabbitMQ::Channel->new(); 14 | $channel->on( 15 | open => sub { 16 | my $queue = $channel->declare_queue(exclusive => 1); 17 | $queue->on( 18 | success => sub { 19 | my $method = $_[1]->method_frame; 20 | my $bind = $channel->bind_queue( 21 | exchange => 'mojo', 22 | queue => $method->queue, 23 | routing_key => '', 24 | ); 25 | $bind->on( 26 | success => sub { 27 | my $consumer = $channel->consume(queue => $method->queue); 28 | $consumer->on( 29 | message => sub { 30 | print "<<< " . $_[1]->{body}->payload . " <<<\n"; 31 | } 32 | ); 33 | $consumer->deliver(); 34 | } 35 | ); 36 | $bind->deliver(); 37 | } 38 | ); 39 | $queue->deliver(); 40 | } 41 | ); 42 | $self->open_channel($channel); 43 | } 44 | ); 45 | $amqp->connect(); 46 | 47 | $amqp->start(); 48 | -------------------------------------------------------------------------------- /examples/chat.pl: -------------------------------------------------------------------------------- 1 | use Mojolicious::Lite; 2 | use Mojo::EventEmitter; 3 | use Mojo::RabbitMQ::Client; 4 | use Mojo::RabbitMQ::Client::Channel; 5 | 6 | helper events => sub { state $events = Mojo::EventEmitter->new }; 7 | 8 | get '/' => 'chat'; 9 | 10 | websocket '/channel' => sub { 11 | my $c = shift; 12 | 13 | $c->inactivity_timeout(3600); 14 | 15 | # Forward messages from the browser 16 | $c->on(message => sub { shift->events->emit(mojochat => ['browser', shift]) } 17 | ); 18 | 19 | # Forward messages to the browser 20 | my $cb = $c->events->on(mojochat => sub { $c->send(join(': ', @{$_[1]})) }); 21 | $c->on(finish => sub { shift->events->unsubscribe(mojochat => $cb) }); 22 | }; 23 | 24 | my $amqp 25 | = Mojo::RabbitMQ::Client->new( 26 | url => ($ENV{MOJO_RABBITMQ_URL} || 'amqp://guest:guest@127.0.0.1:5672/') 27 | ); 28 | $amqp->on( 29 | open => sub { 30 | my ($client) = @_; 31 | warn "client connected"; 32 | 33 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 34 | $channel->catch(sub { warn 'Error on channel received'; }); 35 | $channel->on( 36 | open => sub { 37 | 38 | # Forward every message from browser to message queue 39 | app->events->on( 40 | mojochat => sub { 41 | return unless $_[1]->[0] eq 'browser'; 42 | 43 | $channel->publish( 44 | exchange => 'mojo', 45 | routing_key => '', 46 | body => $_[1]->[1], 47 | mandatory => 0, 48 | immediate => 0, 49 | header => {} 50 | )->deliver(); 51 | } 52 | ); 53 | 54 | # Create anonymous queue and bind it to fanout exchange named mojo 55 | my $queue = $channel->declare_queue(exclusive => 1); 56 | $queue->on( 57 | success => sub { 58 | my $method = $_[1]->method_frame; 59 | my $bind = $channel->bind_queue( 60 | exchange => 'mojo', 61 | queue => $method->queue, 62 | routing_key => '', 63 | ); 64 | $bind->on( 65 | success => sub { 66 | my $consumer = $channel->consume(queue => $method->queue); 67 | 68 | # Forward every received messsage to browser 69 | $consumer->on( 70 | message => sub { 71 | app->events->emit( 72 | mojochat => ['amqp', $_[1]->{body}->payload]); 73 | } 74 | ); 75 | $consumer->deliver(); 76 | } 77 | ); 78 | $bind->deliver(); 79 | } 80 | ); 81 | $queue->deliver(); 82 | } 83 | ); 84 | $channel->on(close => sub { warn 'Channel closed'; }); 85 | $client->open_channel($channel); 86 | } 87 | ); 88 | $amqp->connect(); 89 | 90 | 91 | # Minimal single-process WebSocket chat application for browser testing 92 | app->start; 93 | __DATA__ 94 | 95 | @@ chat.html.ep 96 |
97 |
98 | 105 | -------------------------------------------------------------------------------- /examples/simple.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use Mojo::Base -strict; 3 | use Mojo::Log; 4 | use Mojo::RabbitMQ::Client; 5 | 6 | my $log = Mojo::Log->new(threshold => 'trace'); 7 | my $amqp = Mojo::RabbitMQ::Client->new( 8 | url => 'rabbitmq://guest:guest@127.0.0.1:5672/'); 9 | 10 | $amqp->catch(sub { $log->error("Error connecting to RabbitMQ") }); 11 | $amqp->on(connect => sub { $log->debug("Connected to RabbitMQ host") }); 12 | $amqp->on( 13 | open => sub { 14 | my ($self) = @_; 15 | 16 | $log->debug("Openned connection to RabbitMQ host"); 17 | 18 | my $channel = Mojo::RabbitMQ::Channel->new(); 19 | $channel->catch(sub { $log->debug("Failed to open channel") }); 20 | $channel->on( 21 | open => sub { 22 | my ($channel) = @_; 23 | 24 | $log->debug("Opened channel to RabbitMQ host"); 25 | 26 | $log->debug("Publish sample message to `test_queue` queue"); 27 | my $publish = $channel->publish( 28 | exchange => 'test', 29 | routing_key => 'test_queue', 30 | body => 'Test message', 31 | mandatory => 0, 32 | immediate => 0, 33 | header => {} 34 | ); 35 | $publish->catch(sub { $log->error("Message publish failure") }); 36 | $publish->on(success => sub { $log->debug("Message published") }); 37 | $publish->on(return => sub { $log->warn("Message returned to us") }); 38 | $publish->deliver(); 39 | 40 | my $consumer = $channel->consume(queue => 'test_queue'); 41 | $consumer->catch(sub { $log->error("Error while consuming queue") }); 42 | $consumer->on(success => sub { $log->debug("Consumed") }); 43 | $consumer->on(message => sub { $log->debug("Received a message") }); 44 | $consumer->deliver; 45 | } 46 | ); 47 | $channel->on(close => sub { $log->error('Channel closed') }); 48 | 49 | $self->open_channel($channel); 50 | } 51 | ); 52 | $amqp->on(close => sub { $log->error("RabbitMQ connection closed") }); 53 | $amqp->on(disconnect => sub { $log->error("RabbitMQ disconnected") }); 54 | $amqp->connect(); 55 | 56 | $amqp->start(); 57 | -------------------------------------------------------------------------------- /inc/Module/AutoInstall.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::AutoInstall; 3 | 4 | use strict; 5 | use Cwd (); 6 | use File::Spec (); 7 | use ExtUtils::MakeMaker (); 8 | 9 | use vars qw{$VERSION}; 10 | BEGIN { 11 | $VERSION = '0.3.1'; 12 | } 13 | 14 | # special map on pre-defined feature sets 15 | my %FeatureMap = ( 16 | '' => 'Core Features', # XXX: deprecated 17 | '-core' => 'Core Features', 18 | ); 19 | 20 | # various lexical flags 21 | my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); 22 | my ( 23 | $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, 24 | $UpgradeDeps 25 | ); 26 | my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, 27 | $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, 28 | $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); 29 | 30 | # See if it's a testing or non-interactive session 31 | _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); 32 | _init(); 33 | 34 | sub _accept_default { 35 | $AcceptDefault = shift; 36 | } 37 | 38 | sub _installdeps_target { 39 | $InstallDepsTarget = shift; 40 | } 41 | 42 | sub missing_modules { 43 | return @Missing; 44 | } 45 | 46 | sub do_install { 47 | __PACKAGE__->install( 48 | [ 49 | $Config 50 | ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) 51 | : () 52 | ], 53 | @Missing, 54 | ); 55 | } 56 | 57 | # initialize various flags, and/or perform install 58 | sub _init { 59 | foreach my $arg ( 60 | @ARGV, 61 | split( 62 | /[\s\t]+/, 63 | $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' 64 | ) 65 | ) 66 | { 67 | if ( $arg =~ /^--config=(.*)$/ ) { 68 | $Config = [ split( ',', $1 ) ]; 69 | } 70 | elsif ( $arg =~ /^--installdeps=(.*)$/ ) { 71 | __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); 72 | exit 0; 73 | } 74 | elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { 75 | $UpgradeDeps = 1; 76 | __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); 77 | exit 0; 78 | } 79 | elsif ( $arg =~ /^--default(?:deps)?$/ ) { 80 | $AcceptDefault = 1; 81 | } 82 | elsif ( $arg =~ /^--check(?:deps)?$/ ) { 83 | $CheckOnly = 1; 84 | } 85 | elsif ( $arg =~ /^--skip(?:deps)?$/ ) { 86 | $SkipInstall = 1; 87 | } 88 | elsif ( $arg =~ /^--test(?:only)?$/ ) { 89 | $TestOnly = 1; 90 | } 91 | elsif ( $arg =~ /^--all(?:deps)?$/ ) { 92 | $AllDeps = 1; 93 | } 94 | } 95 | } 96 | 97 | # overrides MakeMaker's prompt() to automatically accept the default choice 98 | sub _prompt { 99 | goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; 100 | 101 | my ( $prompt, $default ) = @_; 102 | my $y = ( $default =~ /^[Yy]/ ); 103 | 104 | print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; 105 | print "$default\n"; 106 | return $default; 107 | } 108 | 109 | # the workhorse 110 | sub import { 111 | my $class = shift; 112 | my @args = @_ or return; 113 | my $core_all; 114 | 115 | print "*** $class version " . $class->VERSION . "\n"; 116 | print "*** Checking for Perl dependencies...\n"; 117 | 118 | my $cwd = Cwd::getcwd(); 119 | 120 | $Config = []; 121 | 122 | my $maxlen = length( 123 | ( 124 | sort { length($b) <=> length($a) } 125 | grep { /^[^\-]/ } 126 | map { 127 | ref($_) 128 | ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) 129 | : '' 130 | } 131 | map { +{@args}->{$_} } 132 | grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } 133 | )[0] 134 | ); 135 | 136 | # We want to know if we're under CPAN early to avoid prompting, but 137 | # if we aren't going to try and install anything anyway then skip the 138 | # check entirely since we don't want to have to load (and configure) 139 | # an old CPAN just for a cosmetic message 140 | 141 | $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; 142 | 143 | while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { 144 | my ( @required, @tests, @skiptests ); 145 | my $default = 1; 146 | my $conflict = 0; 147 | 148 | if ( $feature =~ m/^-(\w+)$/ ) { 149 | my $option = lc($1); 150 | 151 | # check for a newer version of myself 152 | _update_to( $modules, @_ ) and return if $option eq 'version'; 153 | 154 | # sets CPAN configuration options 155 | $Config = $modules if $option eq 'config'; 156 | 157 | # promote every features to core status 158 | $core_all = ( $modules =~ /^all$/i ) and next 159 | if $option eq 'core'; 160 | 161 | next unless $option eq 'core'; 162 | } 163 | 164 | print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; 165 | 166 | $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); 167 | 168 | unshift @$modules, -default => &{ shift(@$modules) } 169 | if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward compatibility 170 | 171 | while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { 172 | if ( $mod =~ m/^-(\w+)$/ ) { 173 | my $option = lc($1); 174 | 175 | $default = $arg if ( $option eq 'default' ); 176 | $conflict = $arg if ( $option eq 'conflict' ); 177 | @tests = @{$arg} if ( $option eq 'tests' ); 178 | @skiptests = @{$arg} if ( $option eq 'skiptests' ); 179 | 180 | next; 181 | } 182 | 183 | printf( "- %-${maxlen}s ...", $mod ); 184 | 185 | if ( $arg and $arg =~ /^\D/ ) { 186 | unshift @$modules, $arg; 187 | $arg = 0; 188 | } 189 | 190 | # XXX: check for conflicts and uninstalls(!) them. 191 | my $cur = _version_of($mod); 192 | if (_version_cmp ($cur, $arg) >= 0) 193 | { 194 | print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; 195 | push @Existing, $mod => $arg; 196 | $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; 197 | } 198 | else { 199 | if (not defined $cur) # indeed missing 200 | { 201 | print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; 202 | } 203 | else 204 | { 205 | # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above 206 | print "too old. ($cur < $arg)\n"; 207 | } 208 | 209 | push @required, $mod => $arg; 210 | } 211 | } 212 | 213 | next unless @required; 214 | 215 | my $mandatory = ( $feature eq '-core' or $core_all ); 216 | 217 | if ( 218 | !$SkipInstall 219 | and ( 220 | $CheckOnly 221 | or ($mandatory and $UnderCPAN) 222 | or $AllDeps 223 | or $InstallDepsTarget 224 | or _prompt( 225 | qq{==> Auto-install the } 226 | . ( @required / 2 ) 227 | . ( $mandatory ? ' mandatory' : ' optional' ) 228 | . qq{ module(s) from CPAN?}, 229 | $default ? 'y' : 'n', 230 | ) =~ /^[Yy]/ 231 | ) 232 | ) 233 | { 234 | push( @Missing, @required ); 235 | $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; 236 | } 237 | 238 | elsif ( !$SkipInstall 239 | and $default 240 | and $mandatory 241 | and 242 | _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) 243 | =~ /^[Nn]/ ) 244 | { 245 | push( @Missing, @required ); 246 | $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; 247 | } 248 | 249 | else { 250 | $DisabledTests{$_} = 1 for map { glob($_) } @tests; 251 | } 252 | } 253 | 254 | if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { 255 | require Config; 256 | my $make = $Config::Config{make}; 257 | if ($InstallDepsTarget) { 258 | print 259 | "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; 260 | } 261 | else { 262 | print 263 | "*** Dependencies will be installed the next time you type '$make'.\n"; 264 | } 265 | 266 | # make an educated guess of whether we'll need root permission. 267 | print " (You may need to do that as the 'root' user.)\n" 268 | if eval '$>'; 269 | } 270 | print "*** $class configuration finished.\n"; 271 | 272 | chdir $cwd; 273 | 274 | # import to main:: 275 | no strict 'refs'; 276 | *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; 277 | 278 | return (@Existing, @Missing); 279 | } 280 | 281 | sub _running_under { 282 | my $thing = shift; 283 | print <<"END_MESSAGE"; 284 | *** Since we're running under ${thing}, I'll just let it take care 285 | of the dependency's installation later. 286 | END_MESSAGE 287 | return 1; 288 | } 289 | 290 | # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; 291 | # if we are, then we simply let it taking care of our dependencies 292 | sub _check_lock { 293 | return unless @Missing or @_; 294 | 295 | if ($ENV{PERL5_CPANM_IS_RUNNING}) { 296 | return _running_under('cpanminus'); 297 | } 298 | 299 | my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; 300 | 301 | if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { 302 | return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); 303 | } 304 | 305 | require CPAN; 306 | 307 | if ($CPAN::VERSION > '1.89') { 308 | if ($cpan_env) { 309 | return _running_under('CPAN'); 310 | } 311 | return; # CPAN.pm new enough, don't need to check further 312 | } 313 | 314 | # last ditch attempt, this -will- configure CPAN, very sorry 315 | 316 | _load_cpan(1); # force initialize even though it's already loaded 317 | 318 | # Find the CPAN lock-file 319 | my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); 320 | return unless -f $lock; 321 | 322 | # Check the lock 323 | local *LOCK; 324 | return unless open(LOCK, $lock); 325 | 326 | if ( 327 | ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) 328 | and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' 329 | ) { 330 | print <<'END_MESSAGE'; 331 | 332 | *** Since we're running under CPAN, I'll just let it take care 333 | of the dependency's installation later. 334 | END_MESSAGE 335 | return 1; 336 | } 337 | 338 | close LOCK; 339 | return; 340 | } 341 | 342 | sub install { 343 | my $class = shift; 344 | 345 | my $i; # used below to strip leading '-' from config keys 346 | my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); 347 | 348 | my ( @modules, @installed, @modules_to_upgrade ); 349 | while (my ($pkg, $ver) = splice(@_, 0, 2)) { 350 | 351 | # grep out those already installed 352 | if (_version_cmp(_version_of($pkg), $ver) >= 0) { 353 | push @installed, $pkg; 354 | if ($UpgradeDeps) { 355 | push @modules_to_upgrade, $pkg, $ver; 356 | } 357 | } 358 | else { 359 | push @modules, $pkg, $ver; 360 | } 361 | } 362 | 363 | if ($UpgradeDeps) { 364 | push @modules, @modules_to_upgrade; 365 | @installed = (); 366 | @modules_to_upgrade = (); 367 | } 368 | 369 | return @installed unless @modules; # nothing to do 370 | return @installed if _check_lock(); # defer to the CPAN shell 371 | 372 | print "*** Installing dependencies...\n"; 373 | 374 | return unless _connected_to('cpan.org'); 375 | 376 | my %args = @config; 377 | my %failed; 378 | local *FAILED; 379 | if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { 380 | while () { chomp; $failed{$_}++ } 381 | close FAILED; 382 | 383 | my @newmod; 384 | while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { 385 | push @newmod, ( $k => $v ) unless $failed{$k}; 386 | } 387 | @modules = @newmod; 388 | } 389 | 390 | if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { 391 | _install_cpanplus( \@modules, \@config ); 392 | } else { 393 | _install_cpan( \@modules, \@config ); 394 | } 395 | 396 | print "*** $class installation finished.\n"; 397 | 398 | # see if we have successfully installed them 399 | while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { 400 | if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { 401 | push @installed, $pkg; 402 | } 403 | elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { 404 | print FAILED "$pkg\n"; 405 | } 406 | } 407 | 408 | close FAILED if $args{do_once}; 409 | 410 | return @installed; 411 | } 412 | 413 | sub _install_cpanplus { 414 | my @modules = @{ +shift }; 415 | my @config = _cpanplus_config( @{ +shift } ); 416 | my $installed = 0; 417 | 418 | require CPANPLUS::Backend; 419 | my $cp = CPANPLUS::Backend->new; 420 | my $conf = $cp->configure_object; 421 | 422 | return unless $conf->can('conf') # 0.05x+ with "sudo" support 423 | or _can_write($conf->_get_build('base')); # 0.04x 424 | 425 | # if we're root, set UNINST=1 to avoid trouble unless user asked for it. 426 | my $makeflags = $conf->get_conf('makeflags') || ''; 427 | if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { 428 | # 0.03+ uses a hashref here 429 | $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; 430 | 431 | } else { 432 | # 0.02 and below uses a scalar 433 | $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) 434 | if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); 435 | 436 | } 437 | $conf->set_conf( makeflags => $makeflags ); 438 | $conf->set_conf( prereqs => 1 ); 439 | 440 | 441 | 442 | while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { 443 | $conf->set_conf( $key, $val ); 444 | } 445 | 446 | my $modtree = $cp->module_tree; 447 | while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { 448 | print "*** Installing $pkg...\n"; 449 | 450 | MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; 451 | 452 | my $success; 453 | my $obj = $modtree->{$pkg}; 454 | 455 | if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { 456 | my $pathname = $pkg; 457 | $pathname =~ s/::/\\W/; 458 | 459 | foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { 460 | delete $INC{$inc}; 461 | } 462 | 463 | my $rv = $cp->install( modules => [ $obj->{module} ] ); 464 | 465 | if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { 466 | print "*** $pkg successfully installed.\n"; 467 | $success = 1; 468 | } else { 469 | print "*** $pkg installation cancelled.\n"; 470 | $success = 0; 471 | } 472 | 473 | $installed += $success; 474 | } else { 475 | print << "."; 476 | *** Could not find a version $ver or above for $pkg; skipping. 477 | . 478 | } 479 | 480 | MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; 481 | } 482 | 483 | return $installed; 484 | } 485 | 486 | sub _cpanplus_config { 487 | my @config = (); 488 | while ( @_ ) { 489 | my ($key, $value) = (shift(), shift()); 490 | if ( $key eq 'prerequisites_policy' ) { 491 | if ( $value eq 'follow' ) { 492 | $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); 493 | } elsif ( $value eq 'ask' ) { 494 | $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); 495 | } elsif ( $value eq 'ignore' ) { 496 | $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); 497 | } else { 498 | die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; 499 | } 500 | push @config, 'prereqs', $value; 501 | } elsif ( $key eq 'force' ) { 502 | push @config, $key, $value; 503 | } elsif ( $key eq 'notest' ) { 504 | push @config, 'skiptest', $value; 505 | } else { 506 | die "*** Cannot convert option $key to CPANPLUS version.\n"; 507 | } 508 | } 509 | return @config; 510 | } 511 | 512 | sub _install_cpan { 513 | my @modules = @{ +shift }; 514 | my @config = @{ +shift }; 515 | my $installed = 0; 516 | my %args; 517 | 518 | _load_cpan(); 519 | require Config; 520 | 521 | if (CPAN->VERSION < 1.80) { 522 | # no "sudo" support, probe for writableness 523 | return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) 524 | and _can_write( $Config::Config{sitelib} ); 525 | } 526 | 527 | # if we're root, set UNINST=1 to avoid trouble unless user asked for it. 528 | my $makeflags = $CPAN::Config->{make_install_arg} || ''; 529 | $CPAN::Config->{make_install_arg} = 530 | join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) 531 | if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); 532 | 533 | # don't show start-up info 534 | $CPAN::Config->{inhibit_startup_message} = 1; 535 | 536 | # set additional options 537 | while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { 538 | ( $args{$opt} = $arg, next ) 539 | if $opt =~ /^(?:force|notest)$/; # pseudo-option 540 | $CPAN::Config->{$opt} = $opt eq 'urllist' ? [$arg] : $arg; 541 | } 542 | 543 | if ($args{notest} && (not CPAN::Shell->can('notest'))) { 544 | die "Your version of CPAN is too old to support the 'notest' pragma"; 545 | } 546 | 547 | local $CPAN::Config->{prerequisites_policy} = 'follow'; 548 | 549 | while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { 550 | MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; 551 | 552 | print "*** Installing $pkg...\n"; 553 | 554 | my $obj = CPAN::Shell->expand( Module => $pkg ); 555 | my $success = 0; 556 | 557 | if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { 558 | my $pathname = $pkg; 559 | $pathname =~ s/::/\\W/; 560 | 561 | foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { 562 | delete $INC{$inc}; 563 | } 564 | 565 | my $rv = do { 566 | if ($args{force}) { 567 | CPAN::Shell->force( install => $pkg ) 568 | } elsif ($args{notest}) { 569 | CPAN::Shell->notest( install => $pkg ) 570 | } else { 571 | CPAN::Shell->install($pkg) 572 | } 573 | }; 574 | 575 | $rv ||= eval { 576 | $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) 577 | ->{install} 578 | if $CPAN::META; 579 | }; 580 | 581 | if ( $rv eq 'YES' ) { 582 | print "*** $pkg successfully installed.\n"; 583 | $success = 1; 584 | } 585 | else { 586 | print "*** $pkg installation failed.\n"; 587 | $success = 0; 588 | } 589 | 590 | $installed += $success; 591 | } 592 | else { 593 | print << "."; 594 | *** Could not find a version $ver or above for $pkg; skipping. 595 | . 596 | } 597 | 598 | MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; 599 | } 600 | 601 | return $installed; 602 | } 603 | 604 | sub _has_cpanplus { 605 | return ( 606 | $HasCPANPLUS = ( 607 | $INC{'CPANPLUS/Config.pm'} 608 | or _load('CPANPLUS::Shell::Default') 609 | ) 610 | ); 611 | } 612 | 613 | # make guesses on whether we're under the CPAN installation directory 614 | sub _under_cpan { 615 | require Cwd; 616 | require File::Spec; 617 | 618 | my $cwd = File::Spec->canonpath( Cwd::getcwd() ); 619 | my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); 620 | 621 | return ( index( $cwd, $cpan ) > -1 ); 622 | } 623 | 624 | sub _update_to { 625 | my $class = __PACKAGE__; 626 | my $ver = shift; 627 | 628 | return 629 | if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade 630 | 631 | if ( 632 | _prompt( "==> A newer version of $class ($ver) is required. Install?", 633 | 'y' ) =~ /^[Nn]/ 634 | ) 635 | { 636 | die "*** Please install $class $ver manually.\n"; 637 | } 638 | 639 | print << "."; 640 | *** Trying to fetch it from CPAN... 641 | . 642 | 643 | # install ourselves 644 | _load($class) and return $class->import(@_) 645 | if $class->install( [], $class, $ver ); 646 | 647 | print << '.'; exit 1; 648 | 649 | *** Cannot bootstrap myself. :-( Installation terminated. 650 | . 651 | } 652 | 653 | # check if we're connected to some host, using inet_aton 654 | sub _connected_to { 655 | my $site = shift; 656 | 657 | return ( 658 | ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( 659 | qq( 660 | *** Your host cannot resolve the domain name '$site', which 661 | probably means the Internet connections are unavailable. 662 | ==> Should we try to install the required module(s) anyway?), 'n' 663 | ) =~ /^[Yy]/ 664 | ); 665 | } 666 | 667 | # check if a directory is writable; may create it on demand 668 | sub _can_write { 669 | my $path = shift; 670 | mkdir( $path, 0755 ) unless -e $path; 671 | 672 | return 1 if -w $path; 673 | 674 | print << "."; 675 | *** You are not allowed to write to the directory '$path'; 676 | the installation may fail due to insufficient permissions. 677 | . 678 | 679 | if ( 680 | eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( 681 | qq( 682 | ==> Should we try to re-execute the autoinstall process with 'sudo'?), 683 | ((-t STDIN) ? 'y' : 'n') 684 | ) =~ /^[Yy]/ 685 | ) 686 | { 687 | 688 | # try to bootstrap ourselves from sudo 689 | print << "."; 690 | *** Trying to re-execute the autoinstall process with 'sudo'... 691 | . 692 | my $missing = join( ',', @Missing ); 693 | my $config = join( ',', 694 | UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) 695 | if $Config; 696 | 697 | return 698 | unless system( 'sudo', $^X, $0, "--config=$config", 699 | "--installdeps=$missing" ); 700 | 701 | print << "."; 702 | *** The 'sudo' command exited with error! Resuming... 703 | . 704 | } 705 | 706 | return _prompt( 707 | qq( 708 | ==> Should we try to install the required module(s) anyway?), 'n' 709 | ) =~ /^[Yy]/; 710 | } 711 | 712 | # load a module and return the version it reports 713 | sub _load { 714 | my $mod = pop; # method/function doesn't matter 715 | my $file = $mod; 716 | $file =~ s|::|/|g; 717 | $file .= '.pm'; 718 | local $@; 719 | return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); 720 | } 721 | 722 | # report version without loading a module 723 | sub _version_of { 724 | my $mod = pop; # method/function doesn't matter 725 | my $file = $mod; 726 | $file =~ s|::|/|g; 727 | $file .= '.pm'; 728 | foreach my $dir ( @INC ) { 729 | next if ref $dir; 730 | my $path = File::Spec->catfile($dir, $file); 731 | next unless -e $path; 732 | require ExtUtils::MM_Unix; 733 | return ExtUtils::MM_Unix->parse_version($path); 734 | } 735 | return undef; 736 | } 737 | 738 | # Load CPAN.pm and it's configuration 739 | sub _load_cpan { 740 | return if $CPAN::VERSION and $CPAN::Config and not @_; 741 | require CPAN; 742 | 743 | # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to 744 | # CPAN::HandleConfig->load. CPAN reports that the redirection 745 | # is deprecated in a warning printed at the user. 746 | 747 | # CPAN-1.81 expects CPAN::HandleConfig->load, does not have 748 | # $CPAN::HandleConfig::VERSION but cannot handle 749 | # CPAN::Config->load 750 | 751 | # Which "versions expect CPAN::Config->load? 752 | 753 | if ( $CPAN::HandleConfig::VERSION 754 | || CPAN::HandleConfig->can('load') 755 | ) { 756 | # Newer versions of CPAN have a HandleConfig module 757 | CPAN::HandleConfig->load; 758 | } else { 759 | # Older versions had the load method in Config directly 760 | CPAN::Config->load; 761 | } 762 | } 763 | 764 | # compare two versions, either use Sort::Versions or plain comparison 765 | # return values same as <=> 766 | sub _version_cmp { 767 | my ( $cur, $min ) = @_; 768 | return -1 unless defined $cur; # if 0 keep comparing 769 | return 1 unless $min; 770 | 771 | $cur =~ s/\s+$//; 772 | 773 | # check for version numbers that are not in decimal format 774 | if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { 775 | if ( ( $version::VERSION or defined( _load('version') )) and 776 | version->can('new') 777 | ) { 778 | 779 | # use version.pm if it is installed. 780 | return version->new($cur) <=> version->new($min); 781 | } 782 | elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) 783 | { 784 | 785 | # use Sort::Versions as the sorting algorithm for a.b.c versions 786 | return Sort::Versions::versioncmp( $cur, $min ); 787 | } 788 | 789 | warn "Cannot reliably compare non-decimal formatted versions.\n" 790 | . "Please install version.pm or Sort::Versions.\n"; 791 | } 792 | 793 | # plain comparison 794 | local $^W = 0; # shuts off 'not numeric' bugs 795 | return $cur <=> $min; 796 | } 797 | 798 | # nothing; this usage is deprecated. 799 | sub main::PREREQ_PM { return {}; } 800 | 801 | sub _make_args { 802 | my %args = @_; 803 | 804 | $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } 805 | if $UnderCPAN or $TestOnly; 806 | 807 | if ( $args{EXE_FILES} and -e 'MANIFEST' ) { 808 | require ExtUtils::Manifest; 809 | my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); 810 | 811 | $args{EXE_FILES} = 812 | [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; 813 | } 814 | 815 | $args{test}{TESTS} ||= 't/*.t'; 816 | $args{test}{TESTS} = join( ' ', 817 | grep { !exists( $DisabledTests{$_} ) } 818 | map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); 819 | 820 | my $missing = join( ',', @Missing ); 821 | my $config = 822 | join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) 823 | if $Config; 824 | 825 | $PostambleActions = ( 826 | ($missing and not $UnderCPAN) 827 | ? "\$(PERL) $0 --config=$config --installdeps=$missing" 828 | : "\$(NOECHO) \$(NOOP)" 829 | ); 830 | 831 | my $deps_list = join( ',', @Missing, @Existing ); 832 | 833 | $PostambleActionsUpgradeDeps = 834 | "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; 835 | 836 | my $config_notest = 837 | join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 838 | 'notest', 1 ) 839 | if $Config; 840 | 841 | $PostambleActionsNoTest = ( 842 | ($missing and not $UnderCPAN) 843 | ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" 844 | : "\$(NOECHO) \$(NOOP)" 845 | ); 846 | 847 | $PostambleActionsUpgradeDepsNoTest = 848 | "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; 849 | 850 | $PostambleActionsListDeps = 851 | '@$(PERL) -le "print for @ARGV" ' 852 | . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); 853 | 854 | my @all = (@Missing, @Existing); 855 | 856 | $PostambleActionsListAllDeps = 857 | '@$(PERL) -le "print for @ARGV" ' 858 | . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); 859 | 860 | return %args; 861 | } 862 | 863 | # a wrapper to ExtUtils::MakeMaker::WriteMakefile 864 | sub Write { 865 | require Carp; 866 | Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; 867 | 868 | if ($CheckOnly) { 869 | print << "."; 870 | *** Makefile not written in check-only mode. 871 | . 872 | return; 873 | } 874 | 875 | my %args = _make_args(@_); 876 | 877 | no strict 'refs'; 878 | 879 | $PostambleUsed = 0; 880 | local *MY::postamble = \&postamble unless defined &MY::postamble; 881 | ExtUtils::MakeMaker::WriteMakefile(%args); 882 | 883 | print << "." unless $PostambleUsed; 884 | *** WARNING: Makefile written with customized MY::postamble() without 885 | including contents from Module::AutoInstall::postamble() -- 886 | auto installation features disabled. Please contact the author. 887 | . 888 | 889 | return 1; 890 | } 891 | 892 | sub postamble { 893 | $PostambleUsed = 1; 894 | my $fragment; 895 | 896 | $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; 897 | 898 | config :: installdeps 899 | \t\$(NOECHO) \$(NOOP) 900 | AUTO_INSTALL 901 | 902 | $fragment .= <<"END_MAKE"; 903 | 904 | checkdeps :: 905 | \t\$(PERL) $0 --checkdeps 906 | 907 | installdeps :: 908 | \t$PostambleActions 909 | 910 | installdeps_notest :: 911 | \t$PostambleActionsNoTest 912 | 913 | upgradedeps :: 914 | \t$PostambleActionsUpgradeDeps 915 | 916 | upgradedeps_notest :: 917 | \t$PostambleActionsUpgradeDepsNoTest 918 | 919 | listdeps :: 920 | \t$PostambleActionsListDeps 921 | 922 | listalldeps :: 923 | \t$PostambleActionsListAllDeps 924 | 925 | END_MAKE 926 | 927 | return $fragment; 928 | } 929 | 930 | 1; 931 | 932 | __END__ 933 | 934 | #line 1197 935 | -------------------------------------------------------------------------------- /lib/Mojo/RabbitMQ/Client.pm: -------------------------------------------------------------------------------- 1 | package Mojo::RabbitMQ::Client; 2 | use Mojo::Base 'Mojo::EventEmitter'; 3 | 4 | use Carp qw(croak confess); 5 | use Mojo::URL; 6 | use Mojo::Home; 7 | use Mojo::IOLoop; 8 | use Mojo::Parameters; 9 | use Mojo::Promise; 10 | use Mojo::Util qw(url_unescape dumper); 11 | use List::Util qw(none); 12 | use Scalar::Util qw(blessed weaken); 13 | use File::Basename 'dirname'; 14 | use File::ShareDir qw(dist_file); 15 | 16 | use Net::AMQP; 17 | use Net::AMQP::Common qw(:all); 18 | 19 | use Mojo::RabbitMQ::Client::Channel; 20 | use Mojo::RabbitMQ::Client::LocalQueue; 21 | require Mojo::RabbitMQ::Client::Consumer; 22 | require Mojo::RabbitMQ::Client::Publisher; 23 | 24 | our $VERSION = "0.3.1"; 25 | 26 | use constant DEBUG => $ENV{MOJO_RABBITMQ_DEBUG} // 0; 27 | 28 | has is_open => 0; 29 | has url => undef; 30 | has tls => sub { shift->_uri_handler('tls') }; 31 | has user => sub { shift->_uri_handler('user') }; 32 | has pass => sub { shift->_uri_handler('pass') }; 33 | has host => sub { shift->_uri_handler('host') }; 34 | has port => sub { shift->_uri_handler('port') }; 35 | has vhost => sub { shift->_uri_handler('vhost') }; 36 | has params => sub { shift->_uri_handler('params') // Mojo::Parameters->new }; 37 | has connect_timeout => sub { $ENV{MOJO_CONNECT_TIMEOUT} // 10 }; 38 | has heartbeat_timeout => 60; 39 | has heartbeat_received => 0; # When did we receive last heartbeat 40 | has heartbeat_sent => 0; # When did we sent last heartbeat 41 | has ioloop => sub { Mojo::IOLoop->singleton }; 42 | has max_buffer_size => 16384; 43 | has max_channels => 0; 44 | has queue => sub { Mojo::RabbitMQ::Client::LocalQueue->new }; 45 | has channels => sub { {} }; 46 | has stream_id => undef; 47 | 48 | sub connect { 49 | my $self = shift; 50 | $self->{buffer} = ''; 51 | 52 | my $id; 53 | $id = $self->_connect(sub { $self->_connected($id) }); 54 | $self->stream_id($id); 55 | 56 | return $id; 57 | } 58 | 59 | sub connect_p { 60 | my $self = shift; 61 | my $promise = Mojo::Promise->new; 62 | 63 | my $id; 64 | 65 | weaken $self; 66 | my $handler = sub { 67 | my ($err) = @_; 68 | if (defined $err) { 69 | return $promise->reject($err); 70 | } 71 | 72 | return $promise->resolve($self); 73 | }; 74 | 75 | $id = $self->_connect(sub { $self->_connected($id, $handler) }); 76 | $self->stream_id($id); 77 | 78 | return $promise; 79 | } 80 | 81 | sub consumer { 82 | my ($class, @params) = @_; 83 | croak "consumer is a static method" if ref $class; 84 | 85 | return Mojo::RabbitMQ::Client::Consumer->new(@params); 86 | } 87 | 88 | sub publisher { 89 | my ($class, @params) = @_; 90 | croak "publisher is a static method" if ref $class; 91 | 92 | return Mojo::RabbitMQ::Client::Publisher->new(@params); 93 | } 94 | 95 | sub param { 96 | my $self = shift; 97 | return undef unless defined $self->params; 98 | return $self->params->param(@_); 99 | } 100 | 101 | sub add_channel { 102 | my $self = shift; 103 | my $channel = shift; 104 | 105 | my $id = $channel->id; 106 | if ($id and $self->channels->{$id}) { 107 | return $channel->emit( 108 | error => 'Channel with id: ' . $id . ' already defined'); 109 | } 110 | 111 | if ($self->max_channels > 0 112 | and scalar keys %{$self->channels} >= $self->max_channels) 113 | { 114 | return $channel->emit(error => 'Maximum number of channels reached'); 115 | } 116 | 117 | if (not $id) { 118 | for my $candidate_id (1 .. (2**16 - 1)) { 119 | next if defined $self->channels->{$candidate_id}; 120 | $id = $candidate_id; 121 | last; 122 | } 123 | unless ($id) { 124 | return $channel->emit(error => 'Ran out of channel ids'); 125 | } 126 | } 127 | 128 | $self->channels->{$id} = $channel->id($id)->client($self); 129 | weaken $channel->{client}; 130 | 131 | return $channel; 132 | } 133 | 134 | sub acquire_channel_p { 135 | my $self = shift; 136 | 137 | my $promise = Mojo::Promise->new; 138 | 139 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 140 | $channel->catch(sub { $promise->reject(@_); undef $promise }); 141 | $channel->on(close => sub { warn "Channel closed" }); 142 | $channel->on(open => sub { $promise->resolve(@_); undef $promise }); 143 | 144 | $self->open_channel($channel); 145 | 146 | return $promise; 147 | } 148 | 149 | sub open_channel { 150 | my $self = shift; 151 | my $channel = shift; 152 | 153 | return $channel->emit(error => 'Client connection not opened') 154 | unless $self->is_open; 155 | 156 | $self->add_channel($channel)->open; 157 | 158 | return $self; 159 | } 160 | 161 | sub delete_channel { 162 | my $self = shift; 163 | return delete $self->channels->{shift}; 164 | } 165 | 166 | sub close { 167 | my $self = shift; 168 | 169 | weaken $self; 170 | $self->_write_expect( 171 | 'Connection::Close' => {}, 172 | 'Connection::CloseOk' => sub { 173 | warn "-- Connection::CloseOk\n" if DEBUG; 174 | $self->emit('close'); 175 | $self->_close; 176 | }, 177 | sub { 178 | $self->_close; 179 | } 180 | ); 181 | } 182 | 183 | sub _loop { $_[0]->ioloop } 184 | 185 | sub _error { 186 | my ($self, $id, $err) = @_; 187 | 188 | $self->emit(error => $err); 189 | } 190 | 191 | sub _uri_handler { 192 | my $self = shift; 193 | my $attr = shift; 194 | 195 | return undef unless defined $self->url; 196 | 197 | $self->url(Mojo::URL->new($self->url)) 198 | unless blessed $self->url && $self->url->isa('Mojo::URL'); 199 | 200 | # Set some defaults 201 | my %defaults = ( 202 | tls => 0, 203 | user => undef, 204 | pass => undef, 205 | host => 'localhost', 206 | port => 5672, 207 | vhost => '/', 208 | params => undef 209 | ); 210 | 211 | # Check secure scheme in url 212 | $defaults{tls} = 1 213 | if $self->url->scheme 214 | =~ /^(amqp|rabbitmq)s$/; # Fallback support for rabbitmq scheme name 215 | $defaults{port} = 5671 if $defaults{tls}; 216 | 217 | # Get host & port 218 | $defaults{host} = $self->url->host 219 | if defined $self->url->host && $self->url->host ne ''; 220 | $defaults{port} = $self->url->port if defined $self->url->port; 221 | 222 | # Get user & password 223 | my $userinfo = $self->url->userinfo; 224 | if (defined $userinfo) { 225 | my ($user, $pass) = split /:/, $userinfo; 226 | $defaults{user} = $user; 227 | $defaults{pass} = $pass; 228 | } 229 | 230 | my $vhost = url_unescape $self->url->path; 231 | $vhost =~ s|^/(.+)$|$1|; 232 | $defaults{vhost} = $vhost if defined $vhost && $vhost ne ''; 233 | 234 | # Query params 235 | my $params = $defaults{params} = $self->url->query; 236 | 237 | # Handle common aliases to internal names 238 | my %aliases = ( 239 | cacertfile => 'ca', 240 | certfile => 'cert', 241 | keyfile => 'key', 242 | fail_if_no_peer_cert => 'verify', 243 | connection_timeout => 'timeout' 244 | ); 245 | $params->param($aliases{$_}, $params->param($_)) 246 | foreach grep { defined $params->param($_) } keys %aliases; 247 | 248 | # Some query parameters are translated to attribute values 249 | my %attributes = ( 250 | heartbeat_timeout => 'heartbeat', 251 | connect_timeout => 'timeout', 252 | max_channels => 'channel_max' 253 | ); 254 | $self->$_($params->param($attributes{$_})) 255 | foreach grep { defined $params->param($attributes{$_}) } keys %attributes; 256 | 257 | # Set all 258 | $self->$_($defaults{$_}) foreach keys %defaults; 259 | 260 | return $self->$attr; 261 | } 262 | 263 | sub _close { 264 | my $self = shift; 265 | $self->_loop->stream($self->stream_id)->close_gracefully; 266 | } 267 | 268 | sub _handle { 269 | my ($self, $id, $close) = @_; 270 | 271 | $self->emit('disconnect'); 272 | 273 | $self->_loop->remove($id); 274 | } 275 | 276 | sub _read { 277 | my ($self, $id, $chunk) = @_; 278 | 279 | warn "<- @{[dumper $chunk]}" if DEBUG; 280 | $self->{buffer} .= $chunk; 281 | $self->_parse_frames; 282 | 283 | return; 284 | } 285 | 286 | sub _parse_frames { 287 | my $self = shift; 288 | 289 | for my $frame (Net::AMQP->parse_raw_frames(\$self->{buffer})) { 290 | 291 | if ($frame->isa('Net::AMQP::Frame::Heartbeat')) { 292 | $self->heartbeat_received(time()); 293 | } 294 | elsif ($frame->isa('Net::AMQP::Frame::Method') 295 | and $frame->method_frame->isa('Net::AMQP::Protocol::Connection::Close')) 296 | { 297 | $self->is_open(0); 298 | 299 | $self->_write_frame(Net::AMQP::Protocol::Connection::CloseOk->new()); 300 | $self->emit(disconnect => "Server side disconnection: " 301 | . $frame->method_frame->{reply_text}); 302 | } 303 | elsif ($frame->channel == 0) { 304 | $self->queue->push($frame); 305 | } 306 | else { 307 | my $channel = $self->channels->{$frame->channel}; 308 | if (defined $channel) { 309 | $channel->_push_queue_or_consume($frame); 310 | } 311 | else { 312 | $self->emit( 313 | error => "Unknown channel id received: " 314 | . ($frame->channel // '(undef)'), 315 | $frame 316 | ); 317 | } 318 | } 319 | } 320 | } 321 | 322 | sub _connect { 323 | my ($self, $cb) = @_; 324 | 325 | # Options 326 | # Parse according to (https://www.rabbitmq.com/uri-spec.html) 327 | my $options = { 328 | address => $self->host, 329 | port => $self->port, 330 | timeout => $self->connect_timeout, 331 | tls => $self->tls, 332 | tls_ca => scalar $self->param('ca'), 333 | tls_cert => scalar $self->param('cert'), 334 | tls_key => scalar $self->param('key') 335 | }; 336 | my $verify = $self->param('verify'); 337 | $options->{tls_verify} = hex $verify if defined $verify; 338 | 339 | # Connect 340 | weaken $self; 341 | my $id; 342 | return $id = $self->_loop->client( 343 | $options => sub { 344 | my ($loop, $err, $stream) = @_; 345 | 346 | # Connection error 347 | return unless $self; 348 | return $self->_error($id, $err) if $err; 349 | 350 | $self->emit(connect => $stream); 351 | 352 | # Connection established 353 | $stream->on(timeout => sub { $self->_error($id, 'Inactivity timeout') }); 354 | $stream->on(close => sub { $self && $self->_handle($id, 1) }); 355 | $stream->on(error => sub { $self && $self->_error($id, pop) }); 356 | $stream->on(read => sub { $self && $self->_read($id, pop) }); 357 | $cb->(); 358 | } 359 | ); 360 | } 361 | 362 | sub _connected { 363 | my ($self, $id, $cb) = @_; 364 | 365 | # Inactivity timeout 366 | my $stream = $self->_loop->stream($id)->timeout(0); 367 | 368 | # Store connection information in transaction 369 | my $handle = $stream->handle; 370 | 371 | # Detect that xml spec was already loaded 372 | my $loaded = eval { Net::AMQP::Protocol::Connection::StartOk->new; 1 }; 373 | unless ($loaded) { # Load AMQP specs 374 | my $file = "amqp0-9-1.stripped.extended.xml"; 375 | 376 | # Original spec is in "fixed_amqp0-8.xml" 377 | my $share = dist_file('Mojo-RabbitMQ-Client', $file); 378 | Net::AMQP::Protocol->load_xml_spec($share); 379 | } 380 | 381 | $self->_write($id => Net::AMQP::Protocol->header); 382 | 383 | weaken $self; 384 | $self->_expect( 385 | 'Connection::Start' => sub { 386 | my $frame = shift; 387 | 388 | my @server_mechanisms = split /\s/, $frame->method_frame->mechanisms; 389 | my $param_mechanism = $self->param('auth_mechanism') // ''; 390 | my @client_mechanisms = ('AMQPLAIN', 'EXTERNAL'); 391 | @client_mechanisms = ($param_mechanism) if ($param_mechanism); 392 | warn "-- Server mechanisms: @server_mechanisms\n" if DEBUG; 393 | warn "-- Client mechanisms: @client_mechanisms\n" if DEBUG; 394 | my $mechanism; 395 | for my $cand (@client_mechanisms) { 396 | if (grep { $_ eq $cand } @server_mechanisms) { 397 | $mechanism = $cand; 398 | last; 399 | } 400 | } 401 | return $self->emit(error => 'No authentication mechanism could be negotiated') 402 | unless $mechanism; 403 | 404 | my @locales = split /\s/, $frame->method_frame->locales; 405 | return $self->emit(error => 'en_US is not found in locales') 406 | if none { $_ eq 'en_US' } @locales; 407 | 408 | $self->{_server_properties} = $frame->method_frame->server_properties; 409 | 410 | warn "-- Connection::Start {product: " . $self->{_server_properties}->{product} . ", version: " . $self->{_server_properties}->{version} . "}\n" if DEBUG; 411 | $self->_write_frame( 412 | Net::AMQP::Protocol::Connection::StartOk->new( 413 | client_properties => { 414 | platform => 'Perl', 415 | product => __PACKAGE__, 416 | information => 'https://github.com/inway/mojo-rabbitmq-client', 417 | version => __PACKAGE__->VERSION, 418 | }, 419 | mechanism => $mechanism, 420 | response => {LOGIN => $self->user, PASSWORD => $self->pass}, 421 | locale => 'en_US', 422 | ), 423 | ); 424 | 425 | $self->_tune($id, $cb); 426 | }, 427 | sub { 428 | $self->emit(error => 'Unable to start connection: ' . shift); 429 | } 430 | ); 431 | } 432 | 433 | sub _tune { 434 | my ($self, $id, $cb) = @_; 435 | 436 | weaken $self; 437 | $self->_expect( 438 | 'Connection::Tune' => sub { 439 | my $frame = shift; 440 | 441 | my $method_frame = $frame->method_frame; 442 | $self->max_buffer_size($method_frame->frame_max); 443 | 444 | my $heartbeat = $self->heartbeat_timeout || $method_frame->heartbeat; 445 | 446 | warn "-- Connection::Tune {frame_max: " . $method_frame->frame_max . ", heartbeat: " . $method_frame->heartbeat . "}\n" if DEBUG; 447 | # Confirm 448 | $self->_write_frame( 449 | Net::AMQP::Protocol::Connection::TuneOk->new( 450 | channel_max => $method_frame->channel_max, 451 | frame_max => $method_frame->frame_max, 452 | heartbeat => $heartbeat, 453 | ), 454 | ); 455 | 456 | # According to https://www.rabbitmq.com/amqp-0-9-1-errata.html 457 | # The client should start sending heartbeats after receiving a Connection.Tune 458 | # method, and start monitoring heartbeats after sending Connection.Open. 459 | # -and- 460 | # Heartbeat frames are sent about every timeout / 2 seconds. After two missed 461 | # heartbeats, the peer is considered to be unreachable. 462 | $self->{heartbeat_tid} = $self->_loop->recurring( 463 | $heartbeat / 2 => sub { 464 | return unless time() - $self->heartbeat_sent > $heartbeat / 2; 465 | $self->_write_frame(Net::AMQP::Frame::Heartbeat->new()); 466 | $self->heartbeat_sent(time()); 467 | } 468 | ) if $heartbeat; 469 | 470 | $self->_write_expect( 471 | 'Connection::Open' => 472 | {virtual_host => $self->vhost, capabilities => '', insist => 1,}, 473 | 'Connection::OpenOk' => sub { 474 | warn "-- Connection::OpenOk\n" if DEBUG; 475 | 476 | $self->is_open(1); 477 | $self->emit('open'); 478 | $cb->() if defined $cb; 479 | }, 480 | sub { 481 | my $err = shift; 482 | $self->emit(error => 'Unable to open connection: ' . $err); 483 | $cb->($err) if defined $cb; 484 | } 485 | ); 486 | }, 487 | sub { 488 | $self->emit(error => 'Unable to tune connection: ' . shift); 489 | } 490 | ); 491 | } 492 | 493 | sub _write_expect { 494 | my $self = shift; 495 | my ($method, $args, $exp, $cb, $failure_cb, $channel_id) = @_; 496 | $method = 'Net::AMQP::Protocol::' . $method; 497 | 498 | $channel_id ||= 0; 499 | 500 | my $method_frame = Net::AMQP::Frame::Method->new( 501 | method_frame => $method->new(%$args) 502 | ); 503 | 504 | $self->_write_frame( 505 | $method_frame, 506 | $channel_id 507 | ); 508 | 509 | return $self->_expect($exp, $cb, $failure_cb, $channel_id); 510 | } 511 | 512 | sub _expect { 513 | my $self = shift; 514 | my ($exp, $cb, $failure_cb, $channel_id) = @_; 515 | my @expected = ref($exp) eq 'ARRAY' ? @$exp : ($exp); 516 | 517 | $channel_id ||= 0; 518 | 519 | my $queue; 520 | if (!$channel_id) { 521 | $queue = $self->queue; 522 | } 523 | else { 524 | my $channel = $self->channels->{$channel_id}; 525 | if (defined $channel) { 526 | $queue = $channel->queue; 527 | } 528 | else { 529 | $failure_cb->( 530 | "Unknown channel id received: " . ($channel_id // '(undef)')); 531 | } 532 | } 533 | 534 | return unless $queue; 535 | 536 | $queue->get( 537 | sub { 538 | my $frame = shift; 539 | 540 | return $failure_cb->("Received data is not method frame") 541 | if not $frame->isa("Net::AMQP::Frame::Method"); 542 | 543 | my $method_frame = $frame->method_frame; 544 | for my $exp (@expected) { 545 | return $cb->($frame) 546 | if $method_frame->isa("Net::AMQP::Protocol::" . $exp); 547 | } 548 | 549 | $failure_cb->("Method is not " 550 | . join(', ', @expected) 551 | . ". It's " 552 | . ref($method_frame)); 553 | } 554 | ); 555 | } 556 | 557 | sub _write_frame { 558 | my $self = shift; 559 | my $id = $self->stream_id; 560 | my ($out, $channel, $cb) = @_; 561 | 562 | if ($out->isa('Net::AMQP::Protocol::Base')) { 563 | $out = $out->frame_wrap; 564 | } 565 | $out->channel($channel // 0); 566 | 567 | return $self->_write($id, $out->to_raw_frame, $cb); 568 | } 569 | 570 | sub _write { 571 | my $self = shift @_; 572 | my $id = shift @_; 573 | my $frame = shift @_; 574 | my $cb = shift @_; 575 | 576 | warn "-> @{[dumper $frame]}" if DEBUG; 577 | 578 | utf8::downgrade($frame); 579 | $self->_loop->stream($id)->write($frame => $cb) 580 | if defined $self->_loop->stream($id); 581 | } 582 | 583 | sub DESTROY { 584 | my $self = shift; 585 | my $ioloop = $self->ioloop or return; 586 | my $heartbeat_tid = $self->{heartbeat_tid}; 587 | 588 | $ioloop->remove($heartbeat_tid) if $heartbeat_tid; 589 | } 590 | 591 | 1; 592 | 593 | =encoding utf8 594 | 595 | =head1 NAME 596 | 597 | Mojo::RabbitMQ::Client - Mojo::IOLoop based RabbitMQ client 598 | 599 | =head1 SYNOPSIS 600 | 601 | use Mojo::RabbitMQ::Client; 602 | 603 | # Supply URL according to (https://www.rabbitmq.com/uri-spec.html) 604 | my $client = Mojo::RabbitMQ::Client->new( 605 | url => 'amqp://guest:guest@127.0.0.1:5672/'); 606 | 607 | # Catch all client related errors 608 | $client->catch(sub { warn "Some error caught in client"; }); 609 | 610 | # When connection is in Open state, open new channel 611 | $client->on( 612 | open => sub { 613 | my ($client) = @_; 614 | 615 | # Create a new channel with auto-assigned id 616 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 617 | 618 | $channel->catch(sub { warn "Error on channel received"; }); 619 | 620 | $channel->on( 621 | open => sub { 622 | my ($channel) = @_; 623 | $channel->qos(prefetch_count => 1)->deliver; 624 | 625 | # Publish some example message to test_queue 626 | my $publish = $channel->publish( 627 | exchange => 'test', 628 | routing_key => 'test_queue', 629 | body => 'Test message', 630 | mandatory => 0, 631 | immediate => 0, 632 | header => {} 633 | ); 634 | # Deliver this message to server 635 | $publish->deliver; 636 | 637 | # Start consuming messages from test_queue 638 | my $consumer = $channel->consume(queue => 'test_queue'); 639 | $consumer->on(message => sub { say "Got a message" }); 640 | $consumer->deliver; 641 | } 642 | ); 643 | $channel->on(close => sub { $log->error('Channel closed') }); 644 | 645 | $client->open_channel($channel); 646 | } 647 | ); 648 | 649 | # Start connection 650 | $client->connect(); 651 | 652 | # Start Mojo::IOLoop if not running already 653 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 654 | 655 | =head2 CONSUMER 656 | 657 | use Mojo::RabbitMQ::Client; 658 | my $consumer = Mojo::RabbitMQ::Client->consumer( 659 | url => 'amqp://guest:guest@127.0.0.1:5672/?exchange=mojo&queue=mojo', 660 | defaults => { 661 | qos => {prefetch_count => 1}, 662 | queue => {durable => 1}, 663 | consumer => {no_ack => 0}, 664 | } 665 | ); 666 | 667 | $consumer->catch(sub { die "Some error caught in Consumer" } ); 668 | $consumer->on('success' => sub { say "Consumer ready" }); 669 | $consumer->on( 670 | 'message' => sub { 671 | my ($consumer, $message) = @_; 672 | 673 | $consumer->channel->ack($message)->deliver; 674 | } 675 | ); 676 | $consumer->start(); 677 | 678 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 679 | 680 | =head2 PUBLISHER 681 | 682 | use Mojo::RabbitMQ::Client; 683 | my $publisher = Mojo::RabbitMQ::Client->publisher( 684 | url => 'amqp://guest:guest@127.0.0.1:5672/?exchange=mojo&routing_key=mojo' 685 | ); 686 | 687 | $publisher->publish('plain text'); 688 | 689 | $publisher->publish( 690 | {encode => { to => 'json'}}, 691 | routing_key => 'mojo_mq' 692 | )->then(sub { 693 | say "Message published"; 694 | })->catch(sub { 695 | die "Publishing failed" 696 | })->wait; 697 | 698 | =head1 DESCRIPTION 699 | 700 | L is a rewrite of L to work on top of L. 701 | 702 | =head1 EVENTS 703 | 704 | L inherits all events from L and can emit the 705 | following new ones. 706 | 707 | =head2 connect 708 | 709 | $client->on(connect => sub { 710 | my ($client, $stream) = @_; 711 | ... 712 | }); 713 | 714 | Emitted when TCP/IP connection with RabbitMQ server is established. 715 | 716 | =head2 open 717 | 718 | $client->on(open => sub { 719 | my ($client) = @_; 720 | ... 721 | }); 722 | 723 | Emitted AMQP protocol Connection.Open-Ok method is received. 724 | 725 | =head2 close 726 | 727 | $client->on(close => sub { 728 | my ($client) = @_; 729 | ... 730 | }); 731 | 732 | Emitted on reception of Connection.Close-Ok method. 733 | 734 | =head2 disconnect 735 | 736 | $client->on(close => sub { 737 | my ($client) = @_; 738 | ... 739 | }); 740 | 741 | Emitted when TCP/IP connection gets disconnected. 742 | 743 | =head1 ATTRIBUTES 744 | 745 | L has following attributes. 746 | 747 | =head2 tls 748 | 749 | my $tls = $client->tls; 750 | $client = $client->tls(1) 751 | 752 | Force secure connection. Default is disabled (C<0>). 753 | 754 | =head2 user 755 | 756 | my $user = $client->user; 757 | $client = $client->user('guest') 758 | 759 | Sets username for authorization, by default it's not defined. 760 | 761 | =head2 pass 762 | 763 | my $pass = $client->pass; 764 | $client = $client->pass('secret') 765 | 766 | Sets user password for authorization, by default it's not defined. 767 | 768 | =head2 host 769 | 770 | my $host = $client->host; 771 | $client = $client->host('localhost') 772 | 773 | Hostname or IP address of RabbitMQ server. Defaults to C. 774 | 775 | =head2 port 776 | 777 | my $port = $client->port; 778 | $client = $client->port(1234) 779 | 780 | Port on which RabbitMQ server listens for new connections. 781 | Defaults to C<5672>, which is standard RabbitMQ server listen port. 782 | 783 | =head2 vhost 784 | 785 | my $vhost = $client->vhost; 786 | $client = $client->vhost('/') 787 | 788 | RabbitMQ virtual server to user. Default is C. 789 | 790 | =head2 params 791 | 792 | my $params = $client->params; 793 | $client = $client->params(Mojo::Parameters->new('verify=1')) 794 | 795 | Sets additional parameters for connection. Default is not defined. 796 | 797 | For list of supported parameters see L. 798 | 799 | =head2 url 800 | 801 | my $url = $client->url; 802 | $client = $client->url('amqp://...'); 803 | 804 | Sets all connection parameters in one string, according to specification from 805 | L. 806 | 807 | amqp_URI = "amqp[s]://" amqp_authority [ "/" vhost ] [ "?" query ] 808 | 809 | amqp_authority = [ amqp_userinfo "@" ] host [ ":" port ] 810 | 811 | amqp_userinfo = username [ ":" password ] 812 | 813 | username = *( unreserved / pct-encoded / sub-delims ) 814 | 815 | password = *( unreserved / pct-encoded / sub-delims ) 816 | 817 | vhost = segment 818 | 819 | =head2 heartbeat_timeout 820 | 821 | my $timeout = $client->heartbeat_timeout; 822 | $client = $client->heartbeat_timeout(180); 823 | 824 | Heartbeats are use to monitor peer reachability in AMQP. 825 | Default value is C<60> seconds, if set to C<0> no heartbeats will be sent. 826 | 827 | =head2 connect_timeout 828 | 829 | my $timeout = $client->connect_timeout; 830 | $client = $client->connect_timeout(5); 831 | 832 | Connection timeout used by L. 833 | Defaults to environment variable C or C<10> seconds 834 | if nothing else is set. 835 | 836 | =head2 max_channels 837 | 838 | my $max_channels = $client->max_channels; 839 | $client = $client->max_channels(10); 840 | 841 | Maximum number of channels allowed to be active. Defaults to C<0> which 842 | means no implicit limit. 843 | 844 | When you try to call C over limit an C will be 845 | emitted on channel saying that: I. 846 | 847 | =head1 STATIC METHODS 848 | 849 | =head2 consumer 850 | 851 | my $client = Mojo::RabbitMQ::Client->consumer(...) 852 | 853 | Shortcut for creating L. 854 | 855 | =head2 publisher 856 | 857 | my $client = Mojo::RabbitMQ::Client->publisher(...) 858 | 859 | Shortcut for creating L. 860 | 861 | =head1 METHODS 862 | 863 | L inherits all methods from L and implements 864 | the following new ones. 865 | 866 | =head2 connect 867 | 868 | $client->connect(); 869 | 870 | Tries to connect to RabbitMQ server and negotiate AMQP protocol. 871 | 872 | =head2 close 873 | 874 | $client->close(); 875 | 876 | =head2 param 877 | 878 | my $param = $client->param('name'); 879 | $client = $client->param(name => 'value'); 880 | 881 | =head2 add_channel 882 | 883 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 884 | ... 885 | $channel = $client->add_channel($channel); 886 | $channel->open; 887 | 888 | =head2 open_channel 889 | 890 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 891 | ... 892 | $client->open_channel($channel); 893 | 894 | =head2 delete_channel 895 | 896 | my $removed = $client->delete_channel($channel->id); 897 | 898 | =head1 SUPPORTED QUERY PARAMETERS 899 | 900 | There's no formal specification, nevertheless a list of common parameters 901 | recognized by officially supported RabbitMQ clients is maintained here: 902 | L. 903 | 904 | Some shortcuts are also supported, you'll find them in parenthesis. 905 | 906 | Aliases are less significant, so when both are specified only primary 907 | value will be used. 908 | 909 | =head2 cacertfile (I) 910 | 911 | Path to Certificate Authority file for TLS. 912 | 913 | =head2 certfile (I) 914 | 915 | Path to the client certificate file for TLS. 916 | 917 | =head2 keyfile (I) 918 | 919 | Path to the client certificate private key file for TLS. 920 | 921 | =head2 fail_if_no_peer_cert (I) 922 | 923 | TLS verification mode, defaults to 0x01 on the client-side if a certificate 924 | authority file has been provided, or 0x00 otherwise. 925 | 926 | =head2 auth_mechanism 927 | 928 | Sets the AMQP authentication mechanism. Defaults to AMQPLAIN. AMQPLAIN and 929 | EXTERNAL are supported; EXTERNAL will only work if L does not need 930 | to do anything beyond passing along a username and password if specified. 931 | 932 | =head2 heartbeat 933 | 934 | Sets requested heartbeat timeout, just like C attribute. 935 | 936 | =head2 connection_timeout (I) 937 | 938 | Sets connection timeout - see L attribute. 939 | 940 | =head2 channel_max 941 | 942 | Sets maximum number of channels - see L attribute. 943 | 944 | =head1 SEE ALSO 945 | 946 | L, L, L 947 | 948 | =head1 COPYRIGHT AND LICENSE 949 | 950 | Copyright (C) 2015-2019, Sebastian Podjasek and others 951 | 952 | Based on L - Copyright (C) 2010 Masahito Ikuta, maintained by C<< bobtfish@bobtfish.net >> 953 | 954 | This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. 955 | 956 | Contains AMQP specification (F) licensed under BSD-style license. 957 | 958 | =cut 959 | -------------------------------------------------------------------------------- /lib/Mojo/RabbitMQ/Client/Channel.pm: -------------------------------------------------------------------------------- 1 | package Mojo::RabbitMQ::Client::Channel; 2 | use Mojo::Base 'Mojo::EventEmitter'; 3 | 4 | use Mojo::Promise; 5 | use Mojo::RabbitMQ::Client::LocalQueue; 6 | use Mojo::RabbitMQ::Client::Method; 7 | use Mojo::RabbitMQ::Client::Method::Publish; 8 | use Scalar::Util qw(isweak weaken); 9 | 10 | use constant DEBUG => $ENV{MOJO_RABBITMQ_DEBUG} // 0; 11 | 12 | has id => 0; 13 | has is_open => 0; 14 | has is_active => 0; 15 | has client => undef; 16 | has queue => sub { Mojo::RabbitMQ::Client::LocalQueue->new }; 17 | has content_queue => sub { Mojo::RabbitMQ::Client::LocalQueue->new }; 18 | has consumer_cbs => sub { {} }; 19 | has return_cbs => sub { {} }; 20 | 21 | sub _open { 22 | warn "Deprecated call to _open on channel"; 23 | return shift->open(@_); 24 | } 25 | 26 | sub open { 27 | my $self = shift; 28 | 29 | if ($self->is_open) { 30 | $self->emit(error => 'Channel has already been opened'); 31 | return $self; 32 | } 33 | 34 | weaken $self; 35 | $self->client->_write_expect( 36 | 'Channel::Open' => {}, 37 | 'Channel::OpenOk' => sub { 38 | warn "-- Channel::OpenOk\n" if DEBUG; 39 | $self->is_open(1)->is_active(1)->emit('open'); 40 | }, 41 | sub { 42 | $self->emit( 43 | error => 'Invalid response received while trying to open channel: ' 44 | . shift); 45 | }, 46 | $self->id, 47 | ); 48 | 49 | return $self; 50 | } 51 | 52 | sub _push_queue_or_consume { 53 | my $self = shift; 54 | my ($frame) = @_; 55 | 56 | weaken $self; 57 | if ($frame->isa('Net::AMQP::Frame::Method')) { 58 | my $method_frame = $frame->method_frame; 59 | 60 | if ($method_frame->isa('Net::AMQP::Protocol::Channel::Close')) { 61 | $self->client->_write_frame(Net::AMQP::Protocol::Channel::CloseOk->new(), 62 | $self->id); 63 | $self->is_open(0)->is_active(0); 64 | $self->client->delete_channel($self->id); 65 | $self->emit(close => $frame); 66 | 67 | return $self; 68 | } 69 | elsif ($method_frame->isa('Net::AMQP::Protocol::Basic::Deliver')) { 70 | my $cb = $self->consumer_cbs->{$method_frame->consumer_tag} || sub { }; 71 | $self->_push_read_header_and_body( 72 | 'deliver', 73 | $frame => sub { 74 | $cb->emit(message => @_); 75 | }, 76 | sub { 77 | $self->emit(error => 'Consumer callback failure: ' . shift); 78 | } 79 | ); 80 | return $self; 81 | } 82 | elsif ($method_frame->isa('Net::AMQP::Protocol::Basic::Return')) { 83 | my $cb 84 | = $self->return_cbs->{$method_frame->exchange . '_' 85 | . $method_frame->routing_key} 86 | || sub { }; 87 | $self->_push_read_header_and_body( 88 | 'return', 89 | $frame => sub { 90 | $cb->emit(reject => @_); 91 | }, 92 | sub { 93 | $self->emit(error => 'Return callback failure: ' . shift); 94 | } 95 | ); 96 | return $self; 97 | } 98 | elsif ($method_frame->isa('Net::AMQP::Protocol::Channel::Flow')) { 99 | $self->is_active($method_frame->active); 100 | $self->client->_write_frame( 101 | Net::AMQP::Protocol::Channel::FlowOk->new( 102 | active => $method_frame->active 103 | ), 104 | $self->id 105 | ); 106 | 107 | return $self; 108 | } 109 | 110 | $self->queue->push($frame); 111 | } 112 | else { 113 | $self->content_queue->push($frame); 114 | } 115 | 116 | return $self; 117 | } 118 | 119 | sub close { 120 | my $self = shift; 121 | my $connection = $self->client or return; 122 | 123 | return $self if !$self->is_open; 124 | 125 | return $self->_close() if 0 == scalar keys %{$self->consumer_cbs}; 126 | 127 | for my $consumer_tag (keys %{$self->consumer_cbs}) { 128 | my $method = $self->cancel(consumer_tag => $consumer_tag); 129 | weaken $self unless isweak $self; 130 | $method->on( 131 | success => sub { 132 | $self->_close(); 133 | } 134 | ); 135 | $method->catch( 136 | sub { 137 | $self->_close(); 138 | $self->emit(error => 'Error canceling consumption: ' . shift, @_); 139 | } 140 | ); 141 | $method->deliver(); 142 | } 143 | 144 | return $self; 145 | } 146 | 147 | sub _close { 148 | my $self = shift; 149 | my %args = @_; 150 | 151 | return unless 0 == scalar keys %{$self->consumer_cbs}; 152 | 153 | $self->client->_write_expect( 154 | 'Channel::Close' => {}, 155 | 'Channel::CloseOk' => sub { 156 | warn "-- Channel::CloseOk\n" if DEBUG; 157 | $self->is_open(0)->is_active(0); 158 | $self->client->delete_channel($self->id); 159 | $self->emit('close'); 160 | }, 161 | sub { 162 | $self->is_open(0)->is_active(0); 163 | $self->client->delete_channel($self->id); 164 | $self->emit(error => 'Failed closing channel: ' . shift); 165 | }, 166 | $self->id, 167 | ); 168 | 169 | return $self; 170 | } 171 | 172 | sub _assert_open { 173 | my $self = shift; 174 | 175 | return 0 unless $self->is_open and $self->is_active; 176 | 177 | return 1; 178 | } 179 | 180 | sub _prepare_method { 181 | my $self = shift; 182 | 183 | my $method = Mojo::RabbitMQ::Client::Method->new( 184 | client => $self->client, 185 | channel => $self 186 | ); 187 | weaken $method->{channel}; 188 | weaken $method->{client}; 189 | 190 | return $method->setup(@_); 191 | } 192 | 193 | sub declare_exchange { 194 | my $self = shift; 195 | 196 | return $self->_prepare_method( 197 | 'Exchange::Declare' => { 198 | type => 'direct', 199 | passive => 0, 200 | durable => 0, 201 | auto_delete => 0, 202 | internal => 0, 203 | @_, # exchange 204 | ticket => 0, 205 | nowait => 0, # FIXME 206 | }, 207 | 'Exchange::DeclareOk' => sub { 208 | warn "-- Exchange::DeclareOk\n" if DEBUG; 209 | } 210 | ); 211 | } 212 | 213 | sub declare_exchange_p { 214 | my $self = shift; 215 | 216 | my $promise = Mojo::Promise->new; 217 | my $method = $self->declare_exchange(@_); 218 | weaken $self; 219 | $method->on('success' => sub { shift; $promise->resolve($self, @_) }); 220 | $method->on('error' => sub { shift; $promise->reject($self, @_) }); 221 | $method->deliver; 222 | 223 | return $promise; 224 | } 225 | 226 | sub delete_exchange { 227 | my $self = shift; 228 | 229 | return $self->_prepare_method( 230 | 'Exchange::Delete' => { 231 | if_unused => 0, 232 | @_, # exchange 233 | ticket => 0, 234 | nowait => 0, # FIXME 235 | }, 236 | 'Exchange::DeleteOk' => sub { 237 | warn "-- Exchange::DeleteOk\n" if DEBUG; 238 | } 239 | ); 240 | } 241 | 242 | sub delete_exchange_p { 243 | my $self = shift; 244 | 245 | my $promise = Mojo::Promise->new; 246 | my $method = $self->delete_exchange(@_); 247 | weaken $self; 248 | $method->on('success' => sub { shift; $promise->resolve($self, @_) }); 249 | $method->on('error' => sub { shift; $promise->reject($self, @_) }); 250 | $method->deliver; 251 | 252 | return $promise; 253 | } 254 | 255 | sub declare_queue { 256 | my $self = shift; 257 | 258 | return $self->_prepare_method( 259 | 'Queue::Declare' => { 260 | queue => '', 261 | passive => 0, 262 | durable => 0, 263 | exclusive => 0, 264 | auto_delete => 0, 265 | no_ack => 1, 266 | @_, 267 | ticket => 0, 268 | nowait => 0, # FIXME 269 | }, 270 | 'Queue::DeclareOk' => sub { 271 | warn "-- Queue::DeclareOk\n" if DEBUG; 272 | } 273 | ); 274 | } 275 | 276 | sub declare_queue_p { 277 | my $self = shift; 278 | 279 | my $promise = Mojo::Promise->new; 280 | my $method = $self->declare_queue(@_); 281 | weaken $self; 282 | $method->on('success' => sub { shift; $promise->resolve($self, @_) }); 283 | $method->on('error' => sub { shift; $promise->reject($self, @_) }); 284 | $method->deliver; 285 | 286 | return $promise; 287 | } 288 | 289 | sub bind_queue { 290 | my $self = shift; 291 | 292 | return $self->_prepare_method( 293 | 'Queue::Bind' => { 294 | @_, # queue, exchange, routing_key 295 | ticket => 0, 296 | nowait => 0, # FIXME 297 | }, 298 | 'Queue::BindOk' => sub { 299 | warn "-- Queue::BindOk\n" if DEBUG; 300 | } 301 | ); 302 | } 303 | 304 | sub bind_queue_p { 305 | my $self = shift; 306 | 307 | my $promise = Mojo::Promise->new; 308 | my $method = $self->bind_queue(@_); 309 | $method->on('success' => sub { shift; $promise->resolve($self, @_) }); 310 | $method->on('error' => sub { shift; $promise->reject($self, @_) }); 311 | $method->deliver; 312 | 313 | return $promise; 314 | } 315 | 316 | sub unbind_queue { 317 | my $self = shift; 318 | 319 | return $self->_prepare_method( 320 | 'Queue::Unbind' => { 321 | @_, # queue, exchange, routing_key 322 | ticket => 0, 323 | }, 324 | 'Queue::UnbindOk' => sub { 325 | warn "-- Queue::UnbindOk\n" if DEBUG; 326 | } 327 | ); 328 | } 329 | 330 | sub unbind_queue_p { 331 | my $self = shift; 332 | 333 | my $promise = Mojo::Promise->new; 334 | my $method = $self->unbind_queue(@_); 335 | weaken $self; 336 | $method->on('success' => sub { shift; $promise->resolve($self, @_) }); 337 | $method->on('error' => sub { shift; $promise->reject($self, @_) }); 338 | $method->deliver; 339 | 340 | return $promise; 341 | } 342 | 343 | sub purge_queue { 344 | my $self = shift; 345 | 346 | return $self->_prepare_method( 347 | 'Queue::Purge' => { 348 | @_, # queue 349 | ticket => 0, 350 | nowait => 0, # FIXME 351 | }, 352 | 'Queue::PurgeOk' => sub { 353 | warn "-- Queue::PurgeOk\n" if DEBUG; 354 | } 355 | ); 356 | } 357 | 358 | sub purge_queue_p { 359 | my $self = shift; 360 | 361 | my $promise = Mojo::Promise->new; 362 | my $method = $self->purge_queue(@_); 363 | weaken $self; 364 | $method->on('success' => sub { shift; $promise->resolve($self, @_) }); 365 | $method->on('error' => sub { shift; $promise->reject($self, @_) }); 366 | $method->deliver; 367 | 368 | return $promise; 369 | } 370 | 371 | sub delete_queue { 372 | my $self = shift; 373 | 374 | return $self->_prepare_method( 375 | 'Queue::Delete' => { 376 | if_unused => 0, 377 | if_empty => 0, 378 | @_, # queue 379 | ticket => 0, 380 | nowait => 0, # FIXME 381 | }, 382 | 'Queue::DeleteOk' => sub { 383 | warn "-- Queue::DeleteOk\n" if DEBUG; 384 | } 385 | ); 386 | } 387 | 388 | sub delete_queue_p { 389 | my $self = shift; 390 | 391 | my $promise = Mojo::Promise->new; 392 | my $method = $self->delete_queue(@_); 393 | weaken $self; 394 | $method->on('success' => sub { shift; $promise->resolve($self, @_) }); 395 | $method->on('error' => sub { shift; $promise->reject($self, @_) }); 396 | $method->deliver; 397 | 398 | return $promise; 399 | } 400 | 401 | sub publish { 402 | my $self = shift; 403 | 404 | return Mojo::RabbitMQ::Client::Method::Publish->new( 405 | client => $self->client, 406 | channel => $self 407 | )->setup(@_); 408 | } 409 | 410 | sub publish_p { 411 | my $self = shift; 412 | 413 | my $promise = Mojo::Promise->new; 414 | my $method = Mojo::RabbitMQ::Client::Method::Publish->new( 415 | client => $self->client, 416 | channel => $self 417 | ); 418 | weaken $method->{client}; 419 | weaken $method->{channel}; 420 | $method->setup(@_); 421 | weaken $self; 422 | $method->on('success' => sub { shift; $promise->resolve($self, @_) }); 423 | $method->on('error' => sub { shift; $promise->reject($self, @_) }); 424 | $method->deliver; 425 | 426 | return $promise; 427 | } 428 | 429 | sub consume { 430 | my $self = shift; 431 | 432 | my $method = $self->_prepare_method( 433 | 'Basic::Consume' => { 434 | consumer_tag => '', 435 | no_local => 0, 436 | no_ack => 1, 437 | exclusive => 0, 438 | @_, 439 | ticket => 0, 440 | nowait => 0 441 | }, 442 | 'Basic::ConsumeOk' => sub { 443 | warn "-- Basic::ConsumeOk\n" if DEBUG; 444 | } 445 | ); 446 | weaken $self; 447 | $method->on( 448 | success => sub { 449 | my $this = shift; 450 | my $frame = shift; 451 | my $tag = $frame->method_frame->consumer_tag; 452 | 453 | $self->consumer_cbs->{$tag} = $this; 454 | } 455 | ); 456 | 457 | return $method; 458 | } 459 | 460 | sub cancel { 461 | my $self = shift; 462 | 463 | my $method = $self->_prepare_method( 464 | 'Basic::Cancel', 465 | { 466 | @_, # consumer_tag 467 | nowait => 0, 468 | }, 469 | 'Basic::CancelOk' => sub { 470 | warn "-- Basic::CancelOk\n" if DEBUG; 471 | } 472 | ); 473 | weaken $self; 474 | $method->on( 475 | success => sub { 476 | my $this = shift; 477 | my $frame = shift; 478 | delete $self->consumer_cbs->{$frame->method_frame->consumer_tag}; 479 | } 480 | ); 481 | return $method; 482 | } 483 | 484 | sub get { 485 | my $self = shift; 486 | 487 | my $method = $self->_prepare_method( 488 | 'Basic::Get', 489 | { 490 | no_ack => 1, 491 | @_, # queue 492 | ticket => 0, 493 | }, 494 | [qw(Basic::GetOk Basic::GetEmpty)] 495 | ); 496 | weaken $self; 497 | $method->on( 498 | success => sub { 499 | warn "-- Basic::GetOk|GetEmpty\n" if DEBUG; 500 | my $this = shift; 501 | my $frame = shift; 502 | 503 | $this->emit(empty => $frame) 504 | if $frame->method_frame->isa('Net::AMQP::Protocol::Basic::GetEmpty'); 505 | $self->_push_read_header_and_body( 506 | 'ok', $frame, 507 | sub { 508 | $this->emit(message => $frame, @_); 509 | }, 510 | sub { 511 | $this->emit(error => 'Failed to get messages from queue'); 512 | } 513 | ); 514 | } 515 | ); 516 | 517 | return $method; 518 | } 519 | 520 | sub get_p { 521 | my $self = shift; 522 | 523 | my $promise = Mojo::Promise->new; 524 | my $method = $self->get(@_); 525 | weaken $self; 526 | $method->on('message' => sub { shift; $promise->resolve($self, @_) }); 527 | $method->on('empty' => sub { shift; $promise->resolve($self, @_) }); 528 | $method->on('error' => sub { shift; $promise->reject($self, @_) }); 529 | $method->deliver; 530 | 531 | return $promise; 532 | } 533 | 534 | sub ack { 535 | my $self = shift; 536 | my %args = (); 537 | if (ref($_[0]) eq 'HASH') { 538 | if (defined $_[0]->{ok}) { 539 | $args{delivery_tag} = $_[0]->{ok}->method_frame->delivery_tag; 540 | } elsif (defined $_[0]->{deliver}) { 541 | $args{delivery_tag} = $_[0]->{deliver}->method_frame->delivery_tag; 542 | } 543 | } else { 544 | %args = @_; 545 | } 546 | 547 | die "ack requires delivery_tag in arguments" unless defined $args{delivery_tag}; 548 | 549 | return $self->_prepare_method( 550 | 'Basic::Ack' => { 551 | delivery_tag => 0, 552 | multiple => 553 | (defined $args{delivery_tag} && $args{delivery_tag} != 0 ? 0 : 1), 554 | %args, 555 | } 556 | ); 557 | } 558 | 559 | sub ack_p { 560 | my $self = shift; 561 | 562 | my $promise = Mojo::Promise->new; 563 | my $method = $self->ack(@_); 564 | weaken $self; 565 | $method->on('success' => sub { shift; $promise->resolve($self, @_) }); 566 | $method->on('error' => sub { shift; $promise->reject($self, @_) }); 567 | $method->deliver; 568 | 569 | return $promise; 570 | } 571 | 572 | sub qos { 573 | my $self = shift; 574 | 575 | return $self->_prepare_method('Basic::Qos', 576 | {prefetch_count => 1, @_, prefetch_size => 0, global => 0,}, 577 | 'Basic::QosOk'); 578 | } 579 | 580 | sub recover { 581 | my $self = shift; 582 | 583 | return $self->_prepare_method('Basic::Recover' => {requeue => 1, @_,}); 584 | } 585 | 586 | sub reject { 587 | my $self = shift; 588 | 589 | return $self->_prepare_method( 590 | 'Basic::Reject' => {delivery_tag => 0, requeue => 0, @_,}); 591 | } 592 | 593 | sub select_tx { 594 | my $self = shift; 595 | 596 | return $self->_prepare_method('Tx::Select', {}, 'Tx::SelectOk'); 597 | } 598 | 599 | sub commit_tx { 600 | my $self = shift; 601 | 602 | return $self->_prepare_method('Tx::Commit', {}, 'Tx::CommitOk'); 603 | } 604 | 605 | sub rollback_tx { 606 | my $self = shift; 607 | 608 | return $self->_prepare_method('Tx::Rollback', {}, 'Tx::RollbackOk'); 609 | } 610 | 611 | sub _push_read_header_and_body { 612 | my $self = shift; 613 | my ($type, $frame, $cb, $failure_cb) = @_; 614 | my $response = {$type => $frame}; 615 | my $body_size = 0; 616 | 617 | $self->content_queue->get( 618 | sub { 619 | my $frame = shift; 620 | 621 | return $failure_cb->('Received data is not header frame') 622 | if !$frame->isa('Net::AMQP::Frame::Header'); 623 | 624 | my $header_frame = $frame->header_frame; 625 | return $failure_cb->('Header is not Protocol::Basic::ContentHeader' 626 | . 'Header was ' 627 | . ref $header_frame) 628 | if !$header_frame->isa('Net::AMQP::Protocol::Basic::ContentHeader'); 629 | 630 | $response->{header} = $header_frame; 631 | $body_size = $frame->body_size; 632 | } 633 | ); 634 | 635 | my $body_payload = ""; 636 | my $next_frame; 637 | $next_frame = sub { 638 | my $frame = shift; 639 | 640 | return $failure_cb->('Received data is not body frame') 641 | if !$frame->isa('Net::AMQP::Frame::Body'); 642 | 643 | $body_payload .= $frame->payload; 644 | 645 | if (length($body_payload) < $body_size) { 646 | 647 | # More to come 648 | $self->content_queue->get($next_frame); 649 | } 650 | else { 651 | $frame->payload($body_payload); 652 | $response->{body} = $frame; 653 | $cb->($response); 654 | } 655 | }; 656 | 657 | $self->content_queue->get($next_frame); 658 | 659 | return $self; 660 | } 661 | 662 | sub DESTROY { 663 | my $self = shift; 664 | $self->close() if defined $self; 665 | return; 666 | } 667 | 668 | 1; 669 | 670 | =encoding utf8 671 | 672 | =head1 NAME 673 | 674 | Mojo::RabbitMQ::Client::Channel - handles all channel related methods 675 | 676 | =head1 SYNOPSIS 677 | 678 | use Mojo::RabbitMQ::Client::Channel; 679 | 680 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 681 | 682 | $channel->catch(sub { warn "Some channel error occurred: " . $_[1] }); 683 | 684 | $channel->on( 685 | open => sub { 686 | my ($channel) = @_; 687 | ... 688 | } 689 | ); 690 | $channel->on(close => sub { warn "Channel closed" }); 691 | 692 | $client->open_channel($channel); 693 | 694 | =head1 DESCRIPTION 695 | 696 | L allows one to call all channel related methods. 697 | 698 | =head1 EVENTS 699 | 700 | L inherits all events from L and can emit the 701 | following new ones. 702 | 703 | =head2 open 704 | 705 | $channel->on(open => sub { 706 | my ($channel) = @_; 707 | ... 708 | }); 709 | 710 | Emitted when channel receives Open-Ok. 711 | 712 | =head2 close 713 | 714 | $channel->on(close=> sub { 715 | my ($channel, $frame) = @_; 716 | ... 717 | }); 718 | 719 | Emitted when channel gets closed, C<$frame> contains close reason. 720 | 721 | =head1 ATTRIBUTES 722 | 723 | L has following attributes. 724 | 725 | =head2 id 726 | 727 | my $id = $channel->id; 728 | $channel->id(20810); 729 | 730 | If not set, L sets it to next free number when channel is opened. 731 | 732 | =head2 is_open 733 | 734 | $channel->is_open ? "Channel is open" : "Channel is closed"; 735 | 736 | =head2 is_active 737 | 738 | $channel->is_active ? "Channel is active" : "Channel is not active"; 739 | 740 | This can be modified on reception of Channel-Flow. 741 | 742 | =head2 client 743 | 744 | my $client = $channel->client; 745 | $channel->client($client); 746 | 747 | =head1 METHODS 748 | 749 | L inherits all methods from L and implements 750 | the following new ones. 751 | 752 | =head2 close 753 | 754 | $channel->close; 755 | 756 | Cancels all consumers and closes channel afterwards. 757 | 758 | =head2 declare_exchange 759 | 760 | my $exchange = $channel->declare_exchange( 761 | exchange => 'mojo', 762 | type => 'fanout', 763 | durable => 1, 764 | ... 765 | )->deliver; 766 | 767 | Verify exchange exists, create if needed. 768 | 769 | This method creates an exchange if it does not already exist, and if the 770 | exchange exists, verifies that it is of the correct and expected class. 771 | 772 | Following arguments are accepted: 773 | 774 | =over 2 775 | 776 | =item exchange 777 | 778 | Unique exchange name 779 | 780 | =item type 781 | 782 | Each exchange belongs to one of a set of exchange types implemented by the server. The 783 | exchange types define the functionality of the exchange - i.e. how messages are routed 784 | through it. It is not valid or meaningful to attempt to change the type of an existing 785 | exchange. 786 | 787 | =item passive 788 | 789 | If set, the server will reply with Declare-Ok if the exchange already exists with the same 790 | name, and raise an error if not. The client can use this to check whether an exchange 791 | exists without modifying the server state. When set, all other method fields except name 792 | and no-wait are ignored. A declare with both passive and no-wait has no effect. Arguments 793 | are compared for semantic equivalence. 794 | 795 | =item durable 796 | 797 | If set when creating a new exchange, the exchange will be marked as durable. Durable exchanges 798 | remain active when a server restarts. Non-durable exchanges (transient exchanges) are purged 799 | if/when a server restarts. 800 | 801 | =item auto_delete 802 | 803 | If set, the exchange is deleted when all queues have finished using it. 804 | 805 | =item internal 806 | 807 | If set, the exchange may not be used directly by publishers, but only when bound to other exchanges. 808 | Internal exchanges are used to construct wiring that is not visible to applications. 809 | 810 | =back 811 | 812 | =head2 declare_exchange_p 813 | 814 | Same as L but auto-delivers method and returns a L object. 815 | 816 | $channel->declare_exchange_p( 817 | exchange => 'mojo', 818 | type => 'fanout', 819 | durable => 1, 820 | ... 821 | )->then(sub { 822 | say "Exchange declared..."; 823 | })->catch(sub { 824 | my $err = shift; 825 | warn "Exchange declaration error: $err"; 826 | })->wait; 827 | 828 | =head2 delete_exchange 829 | 830 | $channel->delete_exchange(exchange => 'mojo')->deliver; 831 | 832 | Delete an exchange. 833 | 834 | This method deletes an exchange. When an exchange is deleted all queue bindings on the exchange 835 | are cancelled. 836 | 837 | Following arguments are accepted: 838 | 839 | =over 2 840 | 841 | =item exchange 842 | 843 | Exchange name. 844 | 845 | =item if_unused 846 | 847 | If set, the server will only delete the exchange if it has no queue bindings. If the exchange has 848 | queue bindings the server does not delete it but raises a channel exception instead. 849 | 850 | =back 851 | 852 | =head2 delete_exchange_p 853 | 854 | Same as L but auto-delivers method and returns a L object. 855 | 856 | $channel->delete_exchange_p( 857 | exchange => 'mojo' 858 | )->then(sub { 859 | say "Exchange deleted..."; 860 | })->catch(sub { 861 | my $err = shift; 862 | warn "Exchange removal error: $err"; 863 | })->wait; 864 | 865 | =head2 declare_queue 866 | 867 | my $queue = $channel->declare_queue(queue => 'mq', durable => 1)->deliver 868 | 869 | Declare queue, create if needed. 870 | 871 | This method creates or checks a queue. When creating a new queue the client can 872 | specify various properties that control the durability of the queue and its contents, 873 | and the level of sharing for the queue. 874 | 875 | Following arguments are accepted: 876 | 877 | =over 2 878 | 879 | =item queue 880 | 881 | The queue name MAY be empty, in which case the server MUST create a new queue with 882 | a unique generated name and return this to the client in the Declare-Ok method. 883 | 884 | =item passive 885 | 886 | If set, the server will reply with Declare-Ok if the queue already exists with the same 887 | name, and raise an error if not. The client can use this to check whether a queue exists 888 | without modifying the server state. When set, all other method fields except name and 889 | no-wait are ignored. A declare with both passive and no-wait has no effect. 890 | Arguments are compared for semantic equivalence. 891 | 892 | =item durable 893 | 894 | If set when creating a new queue, the queue will be marked as durable. Durable queues 895 | remain active when a server restarts. Non-durable queues (transient queues) are purged 896 | if/when a server restarts. Note that durable queues do not necessarily hold persistent 897 | messages, although it does not make sense to send persistent messages to a transient queue. 898 | 899 | =item exclusive 900 | 901 | Exclusive queues may only be accessed by the current connection, and are deleted when 902 | that connection closes. Passive declaration of an exclusive queue by other connections are 903 | not allowed. 904 | 905 | =item auto_delete 906 | 907 | If set, the queue is deleted when all consumers have finished using it. The last consumer 908 | can be cancelled either explicitly or because its channel is closed. If there was no consumer 909 | ever on the queue, it won't be deleted. Applications can explicitly delete auto-delete queues 910 | using the Delete method as normal. 911 | 912 | =back 913 | 914 | =head2 declare_queue_p 915 | 916 | Same as L but auto-delivers method and returns a L object. 917 | 918 | $channel->declare_queue_p( 919 | queue => 'mq', 920 | durable => 1 921 | )->then(sub { 922 | say "Queue declared..."; 923 | })->catch(sub { 924 | my $err = shift; 925 | warn "Queue declaration error: $err"; 926 | })->wait; 927 | 928 | =head2 bind_queue 929 | 930 | $channel->bind_queue( 931 | exchange => 'mojo', 932 | queue => 'mq', 933 | routing_key => '' 934 | )->deliver; 935 | 936 | Bind queue to an exchange. 937 | 938 | This method binds a queue to an exchange. Until a queue is bound it will 939 | not receive any messages. In a classic messaging model, store-and-forward 940 | queues are bound to a direct exchange and subscription queues are bound 941 | to a topic exchange. 942 | 943 | Following arguments are accepted: 944 | 945 | =over 2 946 | 947 | =item queue 948 | 949 | Specifies the name of the queue to bind. 950 | 951 | =item exchange 952 | 953 | Name of the exchange to bind to. 954 | 955 | =item routing_key 956 | 957 | Specifies the routing key for the binding. The routing key is used for 958 | routing messages depending on the exchange configuration. Not all exchanges 959 | use a routing key - refer to the specific exchange documentation. If the 960 | queue name is empty, the server uses the last queue declared on the channel. 961 | If the routing key is also empty, the server uses this queue name for the 962 | routing key as well. If the queue name is provided but the routing key is 963 | empty, the server does the binding with that empty routing key. The meaning 964 | of empty routing keys depends on the exchange implementation. 965 | 966 | =back 967 | 968 | =head2 bind_queue_p 969 | 970 | Same as L but auto-delivers method and returns a L object. 971 | 972 | $channel->bind_queue_p( 973 | exchange => 'mojo', 974 | queue => 'mq', 975 | routing_key => '' 976 | )->then(sub { 977 | say "Queue bound..."; 978 | })->catch(sub { 979 | my $err = shift; 980 | warn "Queue binding error: $err"; 981 | })->wait; 982 | 983 | =head2 unbind_queue 984 | 985 | $channel->unbind_queue( 986 | exchange => 'mojo', 987 | queue => 'mq', 988 | routing_key => '' 989 | )->deliver; 990 | 991 | Unbind a queue from an exchange. 992 | 993 | This method unbinds a queue from an exchange. 994 | 995 | Following arguments are accepted: 996 | 997 | =over 2 998 | 999 | =item queue 1000 | 1001 | Specifies the name of the queue to unbind. 1002 | 1003 | =item exchange 1004 | 1005 | The name of the exchange to unbind from. 1006 | 1007 | =item routing_key 1008 | 1009 | Specifies the routing key of the binding to unbind. 1010 | 1011 | =back 1012 | 1013 | =head2 unbind_queue_p 1014 | 1015 | Same as L but auto-delivers method and returns a L object. 1016 | 1017 | $channel->unbind_queue_p( 1018 | exchange => 'mojo', 1019 | queue => 'mq', 1020 | routing_key => '' 1021 | )->then(sub { 1022 | say "Queue unbound..."; 1023 | })->catch(sub { 1024 | my $err = shift; 1025 | warn "Queue unbinding error: $err"; 1026 | })->wait; 1027 | 1028 | =head2 purge_queue 1029 | 1030 | $channel->purge_queue(queue => 'mq')->deliver; 1031 | 1032 | Purge a queue. 1033 | 1034 | This method removes all messages from a queue which are not awaiting acknowledgment. 1035 | 1036 | Following arguments are accepted: 1037 | 1038 | =over 2 1039 | 1040 | =item queue 1041 | 1042 | Specifies the name of the queue to purge. 1043 | 1044 | =back 1045 | 1046 | =head2 purge_queue_p 1047 | 1048 | Same as L but auto-delivers method and returns a L object. 1049 | 1050 | $channel->purge_queue_p( 1051 | queue => 'mq', 1052 | )->then(sub { 1053 | say "Queue purged..."; 1054 | })->catch(sub { 1055 | my $err = shift; 1056 | warn "Queue purging error: $err"; 1057 | })->wait; 1058 | 1059 | =head2 delete_queue 1060 | 1061 | $channel->delete_queue(queue => 'mq', if_empty => 1)->deliver; 1062 | 1063 | Delete a queue. 1064 | 1065 | This method deletes a queue. When a queue is deleted any pending messages 1066 | are sent to a dead-letter queue if this is defined in the server configuration, 1067 | and all consumers on the queue are cancelled. 1068 | 1069 | Following arguments are accepted: 1070 | 1071 | =over 2 1072 | 1073 | =item queue 1074 | 1075 | Specifies the name of the queue to delete. 1076 | 1077 | =item if_unused 1078 | 1079 | If set, the server will only delete the queue if it has no consumers. If the queue 1080 | has consumers the server does does not delete it but raises a channel exception instead. 1081 | 1082 | =item if_empty 1083 | 1084 | If set, the server will only delete the queue if it has no messages. 1085 | 1086 | =back 1087 | 1088 | =head2 delete_queue_p 1089 | 1090 | Same as L but auto-delivers method and returns a L object. 1091 | 1092 | $channel->delete_queue_p( 1093 | queue => 'mq', 1094 | if_empty => 1 1095 | )->then(sub { 1096 | say "Queue removed..."; 1097 | })->catch(sub { 1098 | my $err = shift; 1099 | warn "Queue removal error: $err"; 1100 | })->wait; 1101 | 1102 | =head2 publish 1103 | 1104 | my $message = $channel->publish( 1105 | exchange => 'mojo', 1106 | routing_key => 'mq', 1107 | body => 'simple text body', 1108 | ); 1109 | $message->deliver(); 1110 | 1111 | Publish a message. 1112 | 1113 | This method publishes a message to a specific exchange. The message will be 1114 | routed to queues as defined by the exchange configuration and distributed to 1115 | any active consumers when the transaction, if any, is committed. 1116 | 1117 | Following arguments are accepted: 1118 | 1119 | =over 2 1120 | 1121 | =item exchange 1122 | 1123 | Specifies the name of the exchange to publish to. The exchange name can be empty, 1124 | meaning the default exchange. If the exchange name is specified, and that exchange 1125 | does not exist, the server will raise a channel exception. 1126 | 1127 | =item routing_key 1128 | 1129 | Specifies the routing key for the message. The routing key is used for routing 1130 | messages depending on the exchange configuration. 1131 | 1132 | =item mandatory 1133 | 1134 | This flag tells the server how to react if the message cannot be routed to a queue. 1135 | If this flag is set, the server will return an unroutable message with a Return method. 1136 | If this flag is zero, the server silently drops the message. 1137 | 1138 | All rejections are emitted as C event. 1139 | 1140 | $message->on(reject => sub { 1141 | my $message = shift; 1142 | my $frame = shift; 1143 | my $method_frame = $frame->method_frame; 1144 | 1145 | my $reply_code = $method_frame->reply_code; 1146 | my $reply_text = $method_frame->reply_text; 1147 | }); 1148 | 1149 | =item immediate 1150 | 1151 | This flag tells the server how to react if the message cannot be routed to a queue consumer 1152 | immediately. If this flag is set, the server will return an undeliverable message with a 1153 | Return method. If this flag is zero, the server will queue the message, but with no guarantee 1154 | that it will ever be consumed. 1155 | 1156 | As said above, all rejections are emitted as C event. 1157 | 1158 | $message->on(reject => sub { ... }); 1159 | 1160 | =back 1161 | 1162 | =head2 consume 1163 | 1164 | my $consumer = $channel->consume(queue => 'mq'); 1165 | $consumer->on(message => sub { ... }); 1166 | $consumer->deliver; 1167 | 1168 | This method asks the server to start a "consumer", which is a transient request for messages from a 1169 | specific queue. Consumers last as long as the channel they were declared on, or until the client cancels 1170 | them. 1171 | 1172 | Following arguments are accepted: 1173 | 1174 | =over 2 1175 | 1176 | =item queue 1177 | 1178 | Specifies the name of the queue to consume from. 1179 | 1180 | =item consumer_tag 1181 | 1182 | Specifies the identifier for the consumer. The consumer tag is local to a channel, so two clients can use the 1183 | same consumer tags. If this field is empty the server will generate a unique tag. 1184 | 1185 | $consumer->on(success => sub { 1186 | my $consumer = shift; 1187 | my $frame = shift; 1188 | 1189 | my $consumer_tag = $frame->method_frame->consumer_tag; 1190 | }); 1191 | 1192 | =item no_local (not implemented in RabbitMQ!) 1193 | 1194 | If the no-local field is set the server will not send messages to the connection that published them. 1195 | 1196 | See L 1197 | 1198 | =item no_ack 1199 | 1200 | If this field is set the server does not expect acknowledgements for messages. That is, when a message 1201 | is delivered to the client the server assumes the delivery will succeed and immediately dequeues it. 1202 | This functionality may increase performance but at the cost of reliability. Messages can get lost if 1203 | a client dies before they are delivered to the application. 1204 | 1205 | =item exclusive 1206 | 1207 | Request exclusive consumer access, meaning only this consumer can access the queue. 1208 | 1209 | =back 1210 | 1211 | =head2 cancel 1212 | 1213 | $channel->cancel(consumer_tag => 'amq.ctag....')->deliver; 1214 | 1215 | End a queue consumer. 1216 | 1217 | This method cancels a consumer. This does not affect already delivered messages, but 1218 | it does mean the server will not send any more messages for that consumer. The client 1219 | may receive an arbitrary number of messages in between sending the cancel method and 1220 | receiving the cancel-ok reply. 1221 | 1222 | Following arguments are accepted: 1223 | 1224 | =over 2 1225 | 1226 | =item consumer_tag 1227 | 1228 | Holds the consumer tag specified by the client or provided by the server. 1229 | 1230 | =back 1231 | 1232 | =head2 get 1233 | 1234 | my $get = $channel->get(queue => 'mq') 1235 | $get->deliver; 1236 | 1237 | Direct access to a queue. 1238 | 1239 | This method provides a direct access to the messages in a queue using 1240 | a synchronous dialogue that is designed for specific types of application 1241 | where synchronous functionality is more important than performance. 1242 | 1243 | This is simple event emitter to which you have to subscribe. It can emit: 1244 | 1245 | =over 2 1246 | 1247 | =item message 1248 | 1249 | Provide client with a message. 1250 | 1251 | This method delivers a message to the client following a get method. A message 1252 | delivered by 'get-ok' must be acknowledged unless the no-ack option was set 1253 | in the get method. 1254 | 1255 | You can access all get-ok reply parameters as below: 1256 | 1257 | $get->on(message => sub { 1258 | my $get = shift; 1259 | my $get_ok = shift; 1260 | my $message = shift; 1261 | 1262 | say "Still got: " . $get_ok->method_frame->message_count; 1263 | }); 1264 | 1265 | =item empty 1266 | 1267 | Indicate no messages available. 1268 | 1269 | This method tells the client that the queue has no messages available for the 1270 | client. 1271 | 1272 | =back 1273 | 1274 | Following arguments are accepted: 1275 | 1276 | =over 2 1277 | 1278 | =item queue 1279 | 1280 | Specifies the name of the queue to get a message from. 1281 | 1282 | =item no_ack 1283 | 1284 | If this field is set the server does not expect acknowledgements for messages. That is, when a message 1285 | is delivered to the client the server assumes the delivery will succeed and immediately dequeues it. 1286 | This functionality may increase performance but at the cost of reliability. Messages can get lost if 1287 | a client dies before they are delivered to the application. 1288 | 1289 | =back 1290 | 1291 | =head2 ack 1292 | 1293 | $channel->ack(delivery_tag => 1); 1294 | 1295 | Acknowledge one or more messages. 1296 | 1297 | When sent by the client, this method acknowledges one or more messages 1298 | delivered via the Deliver or Get-Ok methods. When sent by server, this 1299 | method acknowledges one or more messages published with the Publish 1300 | method on a channel in confirm mode. The acknowledgement can be for 1301 | a single message or a set of messages up to and including a specific 1302 | message. 1303 | 1304 | Following arguments are accepted: 1305 | 1306 | =over 2 1307 | 1308 | =item delivery_tag 1309 | 1310 | Server assigned delivery tag that was received with a message. 1311 | 1312 | =item multiple 1313 | 1314 | If set to 1, the delivery tag is treated as "up to and including", so 1315 | that multiple messages can be acknowledged with a single method. If set 1316 | to zero, the delivery tag refers to a single message. If the multiple 1317 | field is 1, and the delivery tag is zero, this indicates acknowledgement 1318 | of all outstanding messages. 1319 | 1320 | =back 1321 | 1322 | =head2 qos 1323 | 1324 | $channel->qos(prefetch_count => 1)->deliver; 1325 | 1326 | Sets specified Quality of Service to channel, or entire connection. Accepts following arguments: 1327 | 1328 | =over 2 1329 | 1330 | =item prefetch_size 1331 | 1332 | Prefetch window size in octets. 1333 | 1334 | =item prefetch_count 1335 | 1336 | Prefetch window in complete messages. 1337 | 1338 | =item global 1339 | 1340 | If set all settings will be applied connection wide. 1341 | 1342 | =back 1343 | 1344 | =head2 recover 1345 | 1346 | $channel->recover(requeue => 0)->deliver; 1347 | 1348 | Redeliver unacknowledged messages. 1349 | 1350 | This method asks the server to redeliver all unacknowledged messages 1351 | on a specified channel. Zero or more messages may be redelivered. 1352 | 1353 | =over 2 1354 | 1355 | =item requeue 1356 | 1357 | If this field is zero, the message will be redelivered to the original 1358 | recipient. If this bit is 1, the server will attempt to requeue the 1359 | message, potentially then delivering it to an alternative subscriber. 1360 | 1361 | =back 1362 | 1363 | =head2 reject 1364 | 1365 | $channel->reject(delivery_tag => 1, requeue => 0)->deliver; 1366 | 1367 | Reject an incoming message. 1368 | 1369 | This method allows a client to reject a message. It can be 1370 | used to interrupt and cancel large incoming messages, or 1371 | return untreatable messages to their original queue. 1372 | 1373 | Following arguments are accepted: 1374 | 1375 | =over 2 1376 | 1377 | =item delivery_tag 1378 | 1379 | Server assigned delivery tag that was received with a message. 1380 | 1381 | =item requeue 1382 | 1383 | If requeue is true, the server will attempt to requeue the message. 1384 | If requeue is false or the requeue attempt fails the messages are 1385 | discarded or dead-lettered. 1386 | 1387 | =back 1388 | 1389 | =head2 select_tx 1390 | 1391 | Work with transactions. 1392 | 1393 | The Tx class allows publish and ack operations to be batched into atomic units of work. 1394 | The intention is that all publish and ack requests issued within a transaction will 1395 | complete successfully or none of them will. Servers SHOULD implement atomic transactions 1396 | at least where all publish or ack requests affect a single queue. Transactions that cover 1397 | multiple queues may be non-atomic, given that queues can be created and destroyed 1398 | asynchronously, and such events do not form part of any transaction. 1399 | Further, the behaviour of transactions with respect to the immediate and mandatory flags 1400 | on Basic.Publish methods is not defined. 1401 | 1402 | $channel->select_tx()->deliver; 1403 | 1404 | Select standard transaction mode. 1405 | 1406 | This method sets the channel to use standard transactions. The client must use this method 1407 | at least once on a channel before using the Commit or Rollback methods. 1408 | 1409 | =head2 commit_tx 1410 | 1411 | $channel->commit_tx()->deliver; 1412 | 1413 | Commit the current transaction. 1414 | 1415 | This method commits all message publications and acknowledgments performed in the current 1416 | transaction. A new transaction starts immediately after a commit. 1417 | 1418 | =head2 rollback_tx 1419 | 1420 | $channel->rollback_tx()->deliver; 1421 | 1422 | Abandon the current transaction. 1423 | 1424 | This method abandons all message publications and acknowledgments performed in the current 1425 | transaction. A new transaction starts immediately after a rollback. Note that unacked messages 1426 | will not be automatically redelivered by rollback; if that is required an explicit recover 1427 | call should be issued. 1428 | 1429 | =head1 SEE ALSO 1430 | 1431 | L, L, L 1432 | 1433 | =head1 COPYRIGHT AND LICENSE 1434 | 1435 | Copyright (C) 2015-2017, Sebastian Podjasek and others 1436 | 1437 | Based on L - Copyright (C) 2010 Masahito Ikuta, maintained by C<< bobtfish@bobtfish.net >> 1438 | 1439 | This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. 1440 | 1441 | =cut 1442 | -------------------------------------------------------------------------------- /lib/Mojo/RabbitMQ/Client/Consumer.pm: -------------------------------------------------------------------------------- 1 | package Mojo::RabbitMQ::Client::Consumer; 2 | use Mojo::Base 'Mojo::EventEmitter'; 3 | 4 | use Mojo::Promise; 5 | use Scalar::Util 'weaken'; 6 | require Mojo::RabbitMQ::Client; 7 | 8 | use constant DEBUG => $ENV{MOJO_RABBITMQ_DEBUG} // 0; 9 | 10 | has url => undef; 11 | has client => undef; 12 | has channel => undef; 13 | has queue => undef; 14 | has setup => 0; 15 | has defaults => sub { {} }; 16 | 17 | sub consume_p { 18 | my $self = shift; 19 | 20 | my $promise = Mojo::Promise->new()->resolve(); 21 | 22 | weaken $self; 23 | unless ($self->client) { 24 | $promise = $promise->then( 25 | sub { 26 | warn "-- spawn new client\n" if DEBUG; 27 | my $client_promise = Mojo::Promise->new(); 28 | my $client = Mojo::RabbitMQ::Client->new(url => $self->url); 29 | $self->client($client); 30 | 31 | # Catch all client related errors 32 | $self->client->catch(sub { $client_promise->reject($_[1]) }); 33 | 34 | # When connection is in Open state, open new channel 35 | $client->on( 36 | open => sub { 37 | warn "-- client open\n" if DEBUG; 38 | $client_promise->resolve; 39 | } 40 | ); 41 | $client->on('close' => sub { shift; $self->emit('close', @_) }); 42 | 43 | # Start connection 44 | $client->connect; 45 | 46 | return $client_promise; 47 | } 48 | ); 49 | } 50 | 51 | # Create a new channel with auto-assigned id 52 | unless ($self->channel) { 53 | $promise = $promise->then( 54 | sub { 55 | warn "-- create new channel\n" if DEBUG; 56 | my $channel_promise = Mojo::Promise->new; 57 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 58 | 59 | $channel->catch(sub { $channel_promise->reject($_[1]) }); 60 | $channel->on(close => sub { warn 'Channel closed: ' . $_[1]->method_frame->reply_text; }); 61 | 62 | $channel->on( 63 | open => sub { 64 | my ($channel) = @_; 65 | warn "-- channel opened\n" if DEBUG; 66 | 67 | $self->channel($channel); 68 | $channel->qos(%{$self->defaults->{qos}})->deliver; 69 | $channel_promise->resolve; 70 | } 71 | ); 72 | 73 | $self->client->open_channel($channel); 74 | return $channel_promise; 75 | } 76 | ); 77 | } 78 | 79 | # Start consuming messages 80 | $promise = $promise->then( 81 | sub { 82 | my $consumer_promise = Mojo::Promise->new; 83 | my $consumer = $self->channel->consume( 84 | queue => $self->client->url->query->param('queue'), 85 | %{$self->defaults->{consumer}} 86 | ); 87 | $consumer->on( 88 | message => sub { 89 | warn "-- message received\n" if DEBUG; 90 | my ($client, $message) = @_; 91 | $self->emit('message', $message); 92 | } 93 | ); 94 | $consumer->on('success' => sub { $consumer_promise->resolve(@_) }); 95 | $consumer->deliver; 96 | return $consumer_promise; 97 | } 98 | ); 99 | 100 | return $promise; 101 | } 102 | 103 | sub close { 104 | my $self = shift; 105 | 106 | if ($self->client) { 107 | $self->client->close(); 108 | } 109 | } 110 | 111 | 1; 112 | 113 | =encoding utf8 114 | 115 | =head1 NAME 116 | 117 | Mojo::RabbitMQ::Client::Consumer - simple Mojo::RabbitMQ::Client based consumer 118 | 119 | =head1 SYNOPSIS 120 | 121 | use Mojo::RabbitMQ::Client::Consumer; 122 | my $consumer = Mojo::RabbitMQ::Consumer->new( 123 | url => 'amqp://guest:guest@127.0.0.1:5672/?exchange=mojo&queue=mojo', 124 | defaults => { 125 | qos => {prefetch_count => 1}, 126 | queue => {durable => 1}, 127 | consumer => {no_ack => 0}, 128 | } 129 | ); 130 | 131 | $consumer->catch(sub { die "Some error caught in Consumer" } ); 132 | $consumer->on('success' => sub { say "Consumer ready" }); 133 | $consumer->on( 134 | 'message' => sub { 135 | my ($consumer, $message) = @_; 136 | 137 | $consumer->channel->ack($message)->deliver; 138 | } 139 | ); 140 | $consumer->consume_p->wait; 141 | 142 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 143 | 144 | =head1 DESCRIPTION 145 | 146 | =head1 EVENTS 147 | 148 | L inherits all events from L and can emit the 149 | following new ones. 150 | 151 | =head1 ATTRIBUTES 152 | 153 | L has following attributes. 154 | 155 | =head1 METHODS 156 | 157 | L inherits all methods from L and implements 158 | the following new ones. 159 | 160 | =head1 SEE ALSO 161 | 162 | L 163 | 164 | =head1 COPYRIGHT AND LICENSE 165 | 166 | Copyright (C) 2015-2017, Sebastian Podjasek and others 167 | 168 | This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. 169 | 170 | =cut 171 | -------------------------------------------------------------------------------- /lib/Mojo/RabbitMQ/Client/LocalQueue.pm: -------------------------------------------------------------------------------- 1 | package Mojo::RabbitMQ::Client::LocalQueue; 2 | use Mojo::Base -base; 3 | 4 | has message_queue => sub { [] }; 5 | has drain_code_queue => sub { [] }; 6 | 7 | sub push { 8 | my $self = shift; 9 | 10 | CORE::push @{$self->message_queue}, @_; 11 | return $self->_drain_queue(); 12 | } 13 | 14 | sub get { 15 | my $self = shift; 16 | 17 | CORE::push @{$self->drain_code_queue}, @_; 18 | return $self->_drain_queue(); 19 | } 20 | 21 | sub _drain_queue { 22 | my $self = shift; 23 | 24 | my $message_count = scalar @{$self->message_queue}; 25 | my $drain_code_count = scalar @{$self->drain_code_queue}; 26 | 27 | my $count 28 | = $message_count < $drain_code_count ? $message_count : $drain_code_count; 29 | 30 | for (1 .. $count) { 31 | &{shift @{$self->drain_code_queue}}(shift @{$self->message_queue}); 32 | } 33 | 34 | return $self; 35 | } 36 | 37 | 1; 38 | 39 | =encoding utf8 40 | 41 | =head1 NAME 42 | 43 | Mojo::RabbitMQ::Client::LocalQueue - Callback queue 44 | 45 | =head1 SYNOPSIS 46 | 47 | use Mojo::RabbitMQ::Client::LocalQueue 48 | 49 | my $queue = Mojo::RabbitMQ::Client::LocalQueue->new(); 50 | 51 | # Register callback when content appears 52 | $queue->get(sub { say "got expected content: " . $_[0] }); 53 | 54 | # Push some content to consume 55 | $queue->push("It Works!"); 56 | 57 | # This prints: 58 | # got expected content: It Works! 59 | 60 | =head1 DESCRIPTION 61 | 62 | L is a queue for callbacks expecting some content to be received. 63 | 64 | =head1 METHODS 65 | 66 | L implements following methods: 67 | 68 | =head2 get 69 | 70 | $queue->get(sub { process_message($_[0]) }) 71 | 72 | Registers a callback which is executed when new message is pushed to queue. 73 | 74 | =head2 push 75 | 76 | $queue->push("Some content"); 77 | $queue->push({objects => 'are also welcome}); 78 | 79 | Pushes content to queue and also drains all declared callbacks. 80 | 81 | =head1 SEE ALSO 82 | 83 | L, L 84 | 85 | =head1 COPYRIGHT AND LICENSE 86 | 87 | Copyright (C) 2015-2017, Sebastian Podjasek and others 88 | 89 | Based on L - Copyright (C) 2010 Masahito Ikuta, maintained by C<< bobtfish@bobtfish.net >> 90 | 91 | This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. 92 | 93 | =cut 94 | -------------------------------------------------------------------------------- /lib/Mojo/RabbitMQ/Client/Method.pm: -------------------------------------------------------------------------------- 1 | package Mojo::RabbitMQ::Client::Method; 2 | use Mojo::Base 'Mojo::EventEmitter'; 3 | 4 | has is_sent => 0; 5 | has client => undef; 6 | has channel => undef; 7 | has name => undef; 8 | has arguments => sub { {} }; 9 | has expect => undef; 10 | 11 | sub setup { 12 | my $self = shift; 13 | $self->name(shift); 14 | $self->arguments(shift); 15 | $self->expect(shift); 16 | 17 | return $self; 18 | } 19 | 20 | sub deliver { 21 | my $self = shift; 22 | 23 | return 0 unless $self->channel->_assert_open(); 24 | 25 | $self->client->_write_expect( 26 | $self->name => $self->arguments, 27 | $self->expect => sub { $self->emit('success', @_); }, 28 | sub { $self->emit('error', @_); }, $self->channel->id, 29 | ); 30 | $self->is_sent(1); 31 | 32 | return 1; 33 | } 34 | 35 | 1; 36 | 37 | =encoding utf8 38 | 39 | =head1 NAME 40 | 41 | Mojo::RabbitMQ::Client::Method - it's a generic class for all AMQP method calls 42 | 43 | =head1 SYNOPSIS 44 | 45 | use Mojo::RabbitMQ::Client::Method; 46 | 47 | my $method = Mojo::RabbitMQ::Client::Method->new( 48 | client => $client, 49 | channel => $channel 50 | )->setup( 51 | 'Basic::Consume' => { 52 | ... 53 | }, 54 | ['Basic::ConsumeOk', ...] 55 | ); 56 | 57 | # Watch for errors 58 | $method->on(error => sub { warn "Error in reception: " . $_[1] }); 59 | 60 | # Send this frame to AMQP 61 | $method->deliver; 62 | 63 | =head1 DESCRIPTION 64 | 65 | L is general class for every AMQP method call. 66 | 67 | =head1 EVENTS 68 | 69 | L inherits all events from L and can emit the 70 | following new ones. 71 | 72 | =head2 success 73 | 74 | $method->on(success => sub { 75 | my ($method, $frame) = @_; 76 | ... 77 | }); 78 | 79 | Emitted when one of expected replies is received. 80 | 81 | =head2 message 82 | 83 | Can be emitted by consumption & get methods. 84 | 85 | =head2 empty 86 | 87 | Can be emitted by get method, when no messages are available on queue. 88 | 89 | =head1 ATTRIBUTES 90 | 91 | L has following attributes. 92 | 93 | =head2 is_sent 94 | 95 | $method->is_sent ? "Method was sent" : "Method is still pending delivery"; 96 | 97 | =head2 client 98 | 99 | my $client = $method->client; 100 | $method->client($client); 101 | 102 | =head2 name 103 | 104 | my $name = $method->name; 105 | $method->name('Basic::Get'); 106 | 107 | =head2 arguments 108 | 109 | my $arguments = $method->arguments; 110 | $method->arguments({no_ack => 1, ticket => 0, queue => 'amq.queue'}); 111 | 112 | =head2 expect 113 | 114 | my $expectations = $method->expect; 115 | $method->expect([qw(Basic::GetOk Basic::GetEmpty)]); 116 | 117 | =head1 METHODS 118 | 119 | L inherits all methods from L and implements 120 | the following new ones. 121 | 122 | =head2 setup 123 | 124 | $method = $method->setup($name, $arguments, $expectations); 125 | 126 | Sets AMQP method name, its arguments and expected replies. 127 | 128 | =head2 deliver 129 | 130 | my $status = $method->deliver(); 131 | 132 | This delivers AMQP method call to server. Returns C<> when channel is not open, C<> otherwise. 133 | On successful delivery->reply cycle emits C<> event. 134 | C<> is emitted when none of expected replies are received. 135 | 136 | =head1 SEE ALSO 137 | 138 | L, L 139 | 140 | =head1 COPYRIGHT AND LICENSE 141 | 142 | Copyright (C) 2015-2017, Sebastian Podjasek and others 143 | 144 | Based on L - Copyright (C) 2010 Masahito Ikuta, maintained by C<< bobtfish@bobtfish.net >> 145 | 146 | This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. 147 | 148 | =cut 149 | -------------------------------------------------------------------------------- /lib/Mojo/RabbitMQ/Client/Method/Publish.pm: -------------------------------------------------------------------------------- 1 | package Mojo::RabbitMQ::Client::Method::Publish; 2 | use Mojo::Base 'Mojo::RabbitMQ::Client::Method'; 3 | 4 | sub setup { 5 | my $self = shift; 6 | 7 | $self->arguments({@_}); 8 | 9 | return $self; 10 | } 11 | 12 | sub deliver { 13 | my $self = shift; 14 | 15 | return $self if !$self->channel->is_active; 16 | 17 | my %args = %{$self->arguments}; 18 | 19 | my $header_args 20 | = {header => delete $args{header} || {}, weight => delete $args{weight}}; 21 | my $body = delete $args{body} || ''; 22 | 23 | $self->_publish(%args)->_header($header_args, $body)->_body($body, sub { 24 | $self->is_sent(1); 25 | 26 | $self->emit('success'); 27 | }); 28 | 29 | return $self if !$args{mandatory} && !$args{immediate}; 30 | 31 | $self->channel->return_cbs->{($args{exchange} || '') . '_' 32 | . $args{routing_key}} = $self; 33 | 34 | return $self; 35 | } 36 | 37 | sub _publish { 38 | my $self = shift; 39 | my %args = @_; 40 | 41 | $self->client->_write_frame( 42 | Net::AMQP::Protocol::Basic::Publish->new( 43 | exchange => '', 44 | mandatory => 0, 45 | immediate => 0, 46 | %args, # routing_key 47 | ticket => 0, 48 | ), 49 | $self->channel->id 50 | ); 51 | 52 | return $self; 53 | } 54 | 55 | sub _header { 56 | my ($self, $args, $body) = @_; 57 | 58 | $self->client->_write_frame( 59 | Net::AMQP::Frame::Header->new( 60 | weight => $args->{weight} || 0, 61 | body_size => length($body), 62 | header_frame => Net::AMQP::Protocol::Basic::ContentHeader->new( 63 | content_type => 'application/octet-stream', 64 | content_encoding => undef, 65 | headers => {}, 66 | delivery_mode => 1, 67 | priority => 1, 68 | correlation_id => undef, 69 | expiration => undef, 70 | message_id => undef, 71 | timestamp => time, 72 | type => undef, 73 | user_id => $self->client->user, 74 | app_id => undef, 75 | cluster_id => undef, 76 | %{ $args->{header} }, 77 | ), 78 | ), 79 | $self->channel->id 80 | ); 81 | 82 | return $self; 83 | } 84 | 85 | sub _body { 86 | my ($self, $body, $cb) = @_; 87 | 88 | $self->client->_write_frame(Net::AMQP::Frame::Body->new(payload => $body), 89 | $self->channel->id, $cb); 90 | 91 | return $self; 92 | } 93 | 94 | 1; 95 | 96 | =encoding utf8 97 | 98 | =head1 NAME 99 | 100 | Mojo::RabbitMQ::Client::Method::Publish - single class to do all of AMQP Publish method magic 101 | 102 | =head1 SYNOPSIS 103 | 104 | use Mojo::RabbitMQ::Client::Method::Publish; 105 | 106 | my $method = Mojo::RabbitMQ::Client::Method::Publish->new( 107 | client => $client, 108 | channel => $channel 109 | )->setup( 110 | exchange => 'mojo', 111 | routing_key => '', 112 | header => {} 113 | body => 'mojo', 114 | mandatory => 0, 115 | immediate => 0, 116 | )->deliver(); 117 | 118 | =head1 DESCRIPTION 119 | 120 | L is a special class to implement AMQP message publish workflow. 121 | 122 | =head1 EVENTS 123 | 124 | L inherits all events from L. 125 | 126 | =head1 ATTRIBUTES 127 | 128 | L inherits all attributes from L. 129 | 130 | =head1 METHODS 131 | 132 | L inherits all methods from L with 133 | following changes. 134 | 135 | =head2 setup 136 | 137 | $method = $method->setup($arguments); 138 | 139 | Only accepts common arguments for message publish chain. Which is: 140 | 141 | =over 2 142 | 143 | =item Frame::Method 144 | 145 | =over 2 146 | 147 | =item Basic::Publish 148 | 149 | =over 2 150 | 151 | =item * exchange 152 | 153 | =item * routing_key 154 | 155 | =item * mandatory 156 | 157 | =item * immediate 158 | 159 | =back 160 | 161 | =back 162 | 163 | =item Frame::Header 164 | 165 | =over 2 166 | 167 | =item Basic::ContentHeader 168 | 169 | =over 2 170 | 171 | =item * header 172 | 173 | =item * weight 174 | 175 | =back 176 | 177 | =back 178 | 179 | =item Frame::Body 180 | 181 | =over 2 182 | 183 | =item * body (as payload) 184 | 185 | =back 186 | 187 | =back 188 | 189 | =head1 SEE ALSO 190 | 191 | L, L, L 192 | 193 | =head1 COPYRIGHT AND LICENSE 194 | 195 | Copyright (C) 2015-2017, Sebastian Podjasek and others 196 | 197 | Based on L - Copyright (C) 2010 Masahito Ikuta, maintained by C<< bobtfish@bobtfish.net >> 198 | 199 | This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. 200 | 201 | =cut 202 | -------------------------------------------------------------------------------- /lib/Mojo/RabbitMQ/Client/Publisher.pm: -------------------------------------------------------------------------------- 1 | package Mojo::RabbitMQ::Client::Publisher; 2 | use Mojo::Base -base; 3 | 4 | use Mojo::Promise; 5 | use Mojo::JSON qw(encode_json); 6 | use Scalar::Util 'weaken'; 7 | require Mojo::RabbitMQ::Client; 8 | 9 | use constant DEBUG => $ENV{MOJO_RABBITMQ_DEBUG} // 0; 10 | 11 | has url => undef; 12 | has client => undef; 13 | has channel => undef; 14 | has setup => 0; 15 | has defaults => sub { {} }; 16 | 17 | sub publish_p { 18 | my $self = shift; 19 | my $body = shift; 20 | my $headers = {}; 21 | my %args = (); 22 | 23 | if (ref($_[0]) eq 'HASH') { 24 | $headers = shift; 25 | } 26 | if (@_) { 27 | %args = (@_); 28 | } 29 | 30 | my $promise = Mojo::Promise->new()->resolve; 31 | 32 | weaken $self; 33 | unless ($self->client) { 34 | $promise = $promise->then( 35 | sub { 36 | warn "-- spawn new client\n" if DEBUG; 37 | my $client_promise = Mojo::Promise->new(); 38 | 39 | my $client = Mojo::RabbitMQ::Client->new(url => $self->url); 40 | $self->client($client); 41 | 42 | # Catch all client related errors 43 | $self->client->catch(sub { $client_promise->reject($_[1]) }); 44 | 45 | # When connection is in Open state, open new channel 46 | $self->client->on( 47 | open => sub { 48 | warn "-- client open\n" if DEBUG; 49 | $client_promise->resolve; 50 | } 51 | ); 52 | 53 | # Start connection 54 | $client->connect; 55 | 56 | return $client_promise; 57 | } 58 | ); 59 | } 60 | 61 | # Create a new channel with auto-assigned id 62 | unless ($self->channel) { 63 | $promise = $promise->then( 64 | sub { 65 | warn "-- create new channel\n" if DEBUG; 66 | my $channel_promise = Mojo::Promise->new(); 67 | 68 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 69 | 70 | $channel->catch(sub { $channel_promise->reject($_[1]) }); 71 | 72 | $channel->on( 73 | open => sub { 74 | my ($channel) = @_; 75 | $self->channel($channel); 76 | 77 | warn "-- channel opened\n" if DEBUG; 78 | 79 | $channel_promise->resolve; 80 | } 81 | ); 82 | $channel->on(close => sub { warn 'Channel closed: ' . $_[1]->method_frame->reply_text; }); 83 | 84 | $self->client->open_channel($channel); 85 | 86 | return $channel_promise; 87 | } 88 | ); 89 | } 90 | 91 | $promise = $promise->then( 92 | sub { 93 | warn "-- publish message\n" if DEBUG; 94 | my $query = $self->client->url->query; 95 | my $exchange_name = $query->param('exchange'); 96 | my $routing_key = $query->param('routing_key'); 97 | my %headers = (content_type => 'text/plain', %$headers); 98 | 99 | if (ref($body)) { 100 | $headers{content_type} = 'application/json'; 101 | $body = encode_json $body; 102 | } 103 | 104 | return $self->channel->publish_p( 105 | exchange => $exchange_name, 106 | routing_key => $routing_key, 107 | mandatory => 0, 108 | immediate => 0, 109 | header => \%headers, 110 | %args, 111 | body => $body 112 | ); 113 | } 114 | ); 115 | 116 | return $promise; 117 | } 118 | 119 | 1; 120 | 121 | =encoding utf8 122 | 123 | =head1 NAME 124 | 125 | Mojo::RabbitMQ::Client::Publisher - simple Mojo::RabbitMQ::Client based publisher 126 | 127 | =head1 SYNOPSIS 128 | 129 | use Mojo::RabbitMQ::Client::Publisher; 130 | my $publisher = Mojo::RabbitMQ::Client::Publisher->new( 131 | url => 'amqp://guest:guest@127.0.0.1:5672/?exchange=mojo&routing_key=mojo' 132 | ); 133 | 134 | $publisher->publish_p( 135 | {encode => { to => 'json'}}, 136 | routing_key => 'mojo_mq' 137 | )->then(sub { 138 | say "Message published"; 139 | })->catch(sub { 140 | die "Publishing failed" 141 | })->wait; 142 | 143 | =head1 DESCRIPTION 144 | 145 | 146 | 147 | =head1 ATTRIBUTES 148 | 149 | L has following attributes. 150 | 151 | =head2 url 152 | 153 | Sets all connection parameters in one string, according to specification from 154 | L. 155 | 156 | For detailed description please see L. 157 | 158 | =head1 METHODS 159 | 160 | L implements only single method. 161 | 162 | =head2 publish_p 163 | 164 | $publisher->publish_p('simple plain text body'); 165 | 166 | $publisher->publish_p({ some => 'json' }); 167 | 168 | $publisher->publish_p($body, { header => 'content' }, routing_key => 'mojo', mandatory => 1); 169 | 170 | Method signature 171 | 172 | publish_p($body!, \%headers?, *@params) 173 | 174 | =over 2 175 | 176 | =item body 177 | 178 | First argument is mandatory body content of published message. 179 | Any reference passed here will be encoded as JSON and accordingly C header 180 | will be set to C. 181 | 182 | =item headers 183 | 184 | If second argument is a HASHREF it will be merged to message headers. 185 | 186 | =item params 187 | 188 | Any other arguments will be considered key/value pairs and passed to the Client's publish 189 | method as arguments overriding everything besides body argument. 190 | 191 | So this: 192 | 193 | $publisher->publish({ json => 'object' }, { header => 'content' }); 194 | 195 | is similar to this: 196 | 197 | $publisher->publish({ json => 'object' }, header => { header => 'content' }); 198 | 199 | But beware - headers passed as a HASHREF get merged into the header constructed by the Publisher, 200 | but params override values; so if you pass C
as a param like this, it will override the 201 | header constructed by the Publisher, and the message will lack the C header, even 202 | though you passed a reference as the body argument! With the first example, the C 203 | header would be included. 204 | 205 | =back 206 | 207 | =head1 SEE ALSO 208 | 209 | L 210 | 211 | =head1 COPYRIGHT AND LICENSE 212 | 213 | Copyright (C) 2015-2017, Sebastian Podjasek and others 214 | 215 | This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. 216 | 217 | =cut 218 | -------------------------------------------------------------------------------- /minil.toml: -------------------------------------------------------------------------------- 1 | name = "Mojo-RabbitMQ-Client" 2 | license = 'artistic_2' 3 | badges = ["travis","metacpan"] 4 | markdown_maker = "Pod::Markdown::Github" 5 | module_maker="ModuleBuildTiny" 6 | 7 | -------------------------------------------------------------------------------- /share/amqp0-9-1.stripped.extended.xml: -------------------------------------------------------------------------------- 1 | 2 | 16 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | 230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | 242 | 243 | 244 | 245 | 246 | 247 | 248 | 249 | 250 | 251 | 252 | 253 | 254 | 255 | 256 | 257 | 258 | 259 | 260 | 261 | 262 | 263 | 264 | 265 | 266 | 267 | 268 | 269 | 270 | 271 | 272 | 273 | 274 | 275 | 276 | 277 | 278 | 279 | 280 | 281 | 282 | 283 | 284 | 285 | 286 | 287 | 288 | 289 | 290 | 291 | 292 | 293 | 294 | 295 | 296 | 297 | 298 | 299 | 300 | 301 | 302 | 303 | 304 | 305 | 306 | 307 | 308 | 309 | 310 | 311 | 312 | 313 | 314 | 315 | 316 | 317 | 318 | 319 | 320 | 321 | 322 | 323 | 324 | 325 | 326 | 327 | 328 | 329 | 330 | 331 | 332 | 333 | 334 | 335 | 336 | 337 | 338 | 339 | 340 | 341 | 342 | 343 | 344 | 345 | 346 | 347 | 348 | 349 | 350 | 351 | 352 | 353 | 354 | 355 | 356 | 357 | 358 | 359 | 360 | 361 | 362 | 363 | 364 | 365 | 366 | 367 | 368 | 369 | 370 | 371 | 372 | 373 | 374 | 375 | 376 | 377 | 378 | 379 | 380 | 381 | 382 | 383 | 384 | 385 | 386 | 387 | 388 | 389 | 390 | 391 | 392 | 393 | 394 | 395 | 396 | 397 | 398 | 399 | 400 | 401 | 402 | 403 | 404 | 405 | 406 | 407 | 408 | 409 | 410 | 411 | 412 | 413 | 414 | 415 | 416 | 417 | 418 | 419 | 420 | 421 | 422 | 423 | 424 | 425 | 426 | 427 | 428 | 429 | 430 | 431 | 432 | 433 | 434 | 435 | 436 | 437 | 438 | 439 | 440 | 441 | 442 | 443 | 444 | 445 | 446 | 447 | 448 | 449 | 450 | 451 | 452 | 453 | 454 | 455 | 456 | 457 | 458 | 459 | 460 | 461 | 462 | 463 | 464 | 465 | 466 | 467 | 468 | 469 | 470 | 471 | 472 | 473 | 474 | 475 | 476 | 477 | 478 | 479 | 480 | 481 | 482 | 483 | 484 | 485 | 486 | 487 | 488 | 489 | 490 | 491 | 492 | 493 | 494 | 495 | 496 | 497 | 498 | 499 | 500 | 501 | 502 | 503 | 504 | 505 | 506 | 507 | 508 | 509 | 510 | 511 | 512 | 513 | 514 | 515 | 516 | 517 | 518 | 519 | 520 | 521 | 522 | 523 | 524 | 525 | 526 | 527 | 528 | 529 | 530 | -------------------------------------------------------------------------------- /t/base.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More tests => 7; 3 | 4 | use_ok 'Mojo::RabbitMQ::Client'; 5 | 6 | subtest 'attributes' => sub { 7 | plan tests => 7; 8 | 9 | my $c = new_ok( 10 | 'Mojo::RabbitMQ::Client', 11 | [ 12 | tls => 0, 13 | user => 'guest', 14 | host => 'remote', 15 | port => 16526, 16 | vhost => '/some/' 17 | ] 18 | ); 19 | 20 | is($c->user, 'guest', 'user is guest'); 21 | is($c->pass, undef, 'no password'); 22 | is($c->host, 'remote', 'host is remote'); 23 | is($c->port, 16526, 'port is ok'); 24 | is($c->vhost, '/some/', 'proper vhost name'); 25 | isa_ok($c->params, 'Mojo::Parameters'); 26 | }; 27 | 28 | subtest 'query param aliases' => sub { 29 | plan tests => 6; 30 | 31 | my $a = new_ok( 32 | 'Mojo::RabbitMQ::Client', 33 | [ 34 | url => 'amqp:///?cacertfile=cacert&certfile=cert&keyfile=key' 35 | . '&fail_if_no_peer_cert=1&connection_timeout=100' 36 | ] 37 | ); 38 | 39 | is($a->param('ca'), 'cacert', 'cacertfile aliased to ca'); 40 | is($a->param('cert'), 'cert', 'cerfile aliased to cert'); 41 | is($a->param('key'), 'key', 'keyfile aliased to key'); 42 | is($a->param('verify'), '1', 'fail_if_no_peer_cert aliased to verify'); 43 | is($a->param('timeout'), '100', 'connection_timeout aliased to timeout'); 44 | }; 45 | 46 | subtest 'query param aliases less significant' => sub { 47 | plan tests => 2; 48 | 49 | my $a = new_ok('Mojo::RabbitMQ::Client', 50 | [url => 'amqp:///?cacertfile=cacert&ca=ca']); 51 | 52 | is($a->param('ca'), 'cacert', 'should take base value, not alias'); 53 | }; 54 | 55 | subtest 'attributes from query params' => sub { 56 | plan tests => 5; 57 | 58 | my $a = new_ok('Mojo::RabbitMQ::Client', 59 | [url => 'amqp://?heartbeat=180&timeout=90&channel_max=1']); 60 | 61 | is($a->host, 'localhost', 'need this to parse url!'); 62 | is($a->heartbeat_timeout, 180, 'heartbeat timeout set'); 63 | is($a->connect_timeout, 90, 'connect timeout set'); 64 | is($a->max_channels, 1, 'max channels set'); 65 | }; 66 | 67 | subtest 'change default port for amqps scheme' => sub { 68 | plan tests => 6; 69 | 70 | my $c = new_ok('Mojo::RabbitMQ::Client', [url => 'amqps://']); 71 | 72 | is($c->user, undef, 'no user'); 73 | is($c->pass, undef, 'no password'); 74 | is($c->host, 'localhost', 'default host'); 75 | is($c->port, 5671, 'changed port'); 76 | is($c->vhost, '/', 'default vhost'); 77 | }; 78 | 79 | subtest 'keep specified port for amqps scheme' => sub { 80 | plan tests => 6; 81 | 82 | my $c = new_ok('Mojo::RabbitMQ::Client', [url => 'amqps://:15673']); 83 | 84 | is($c->user, undef, 'no user'); 85 | is($c->pass, undef, 'no password'); 86 | is($c->host, 'localhost', 'default host'); 87 | is($c->port, 15673, 'changed port'); 88 | is($c->vhost, '/', 'default vhost'); 89 | }; 90 | -------------------------------------------------------------------------------- /t/localqueue.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 10; 2 | 3 | use Mojo::RabbitMQ::Client::LocalQueue; 4 | 5 | my $q = Mojo::RabbitMQ::Client::LocalQueue->new; 6 | 7 | $q->push(1); 8 | $q->get(sub {is $_[0], 1, 'push -> get';}); 9 | 10 | $q->get(sub {is $_[0], 2, 'get -> push';}); 11 | $q->push(2); 12 | 13 | $q->push(3, 4); 14 | $q->push(5, 6); 15 | $q->get( 16 | sub {is $_[0], 3, '';}, 17 | sub {is $_[0], 4, '';}, 18 | ); 19 | $q->get( 20 | sub {is $_[0], 5, '';}, 21 | sub {is $_[0], 6, '';}, 22 | ); 23 | 24 | $q->get( 25 | sub {is $_[0], 7, '';}, 26 | sub {is $_[0], 8, '';}, 27 | ); 28 | $q->get( 29 | sub {is $_[0], 9, '';}, 30 | sub {is $_[0], 10, '';}, 31 | ); 32 | $q->push(7, 8); 33 | $q->push(9, 10); 34 | -------------------------------------------------------------------------------- /t/publisher.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 9; 2 | 3 | BEGIN { 4 | use_ok 'Mojo::RabbitMQ::Client'; 5 | use_ok 'Mojo::RabbitMQ::Client::Publisher'; 6 | } 7 | 8 | SKIP: { 9 | skip "Not requested by user, set TEST_RMQ=1 environment variable to test", 7 unless $ENV{TEST_RMQ}; 10 | 11 | my $run_id = time(); 12 | my $exchange_name = 'mrc_test_' . $run_id; 13 | my $queue_name = 'mrc_test_queue' . $run_id; 14 | 15 | my $url 16 | = $ENV{MOJO_RABBITMQ_URL} 17 | || 'amqp://guest:guest@127.0.0.1:5672/?exchange=' 18 | . $exchange_name 19 | . '&routing_key=' 20 | . $queue_name; 21 | 22 | # setup 23 | my $client = Mojo::RabbitMQ::Client->new(url => $url); 24 | $client->connect_p->then( 25 | sub { 26 | shift->acquire_channel_p(); 27 | } 28 | )->then( 29 | sub { 30 | shift->declare_exchange_p( 31 | exchange => $exchange_name, 32 | type => 'topic', 33 | auto_delete => 1 34 | ); 35 | } 36 | )->then( 37 | sub { 38 | shift->declare_queue_p(queue => $queue_name, auto_delete => 1); 39 | } 40 | )->then( 41 | sub { 42 | shift->bind_queue_p( 43 | exchange => $exchange_name, 44 | queue => $queue_name, 45 | routing_key => $queue_name, 46 | ); 47 | } 48 | )->wait; 49 | 50 | # tests 51 | my @tests = ( 52 | ['plain text', 'plain text', 'text/plain'], 53 | ['hash as json', {json => 'object'}, 'application/json'], 54 | ['array as json', ['array'], 'application/json'], 55 | ); 56 | 57 | my $publisher = Mojo::RabbitMQ::Client::Publisher->new(url => $url); 58 | 59 | foreach my $t (@tests) { 60 | $publisher->publish_p($t->[1])->then(sub { pass('published: ' . $t->[0]) })->wait; 61 | } 62 | 63 | $publisher->publish_p( 64 | {json => 'object'}, 65 | {content_type => 'text/plain'}, 66 | routing_key => '#' 67 | )->then(sub { pass('json published into the void') })->wait; 68 | 69 | 70 | # verify 71 | my $channel; 72 | Mojo::RabbitMQ::Client->new(url => $url)->connect_p->then( 73 | sub { 74 | shift->acquire_channel_p(); 75 | } 76 | )->then( 77 | sub { 78 | $channel = shift; 79 | } 80 | )->wait; 81 | 82 | foreach my $t (@tests) { 83 | $channel->get_p(queue => $queue_name, no_ack => 1)->then( 84 | sub { 85 | my $channel = shift; 86 | my $frame = shift; 87 | my $message = shift; 88 | 89 | if ($message and $message->{header}->{content_type} eq $t->[2]) { 90 | pass("received valid content_type: " . $t->[2]); 91 | } else { 92 | diag explain $frame; 93 | diag explain $message; 94 | pass("received something not valid, expecting " . $t->[2] . " got " . ($message->{header}->{content_type} // '(undef)')); 95 | # SHOULD fail 96 | } 97 | } 98 | )->wait; 99 | } 100 | 101 | # There should be nothing else waiting 102 | $channel->get_p(queue => $queue_name, no_ack => 1)->then( 103 | sub { 104 | my $channel = shift; 105 | diag explain \@_; 106 | pass("received something extra") if defined $_[1]; # SHOULD fail 107 | } 108 | )->wait; 109 | } 110 | 111 | __END__ 112 | my $channel = Mojo::RabbitMQ::Client->new(url => $url)->connect_p->then(sub { shift->acquire_channel_p() }->wait; 113 | 114 | foreach my $t (@tests) { 115 | my ($channel, $frame, $message) = $channel->get_p(queue => $queue_name, no_ack => 1)->wait; 116 | 117 | if ($message and $message->{header}->{content_type} eq $t->[2]) { 118 | pass("received valid content_type"); 119 | } else { 120 | fail("received something not valid"); 121 | } 122 | } 123 | -------------------------------------------------------------------------------- /t/static.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More tests => 5; 3 | use Test::Exception; 4 | 5 | use_ok 'Mojo::RabbitMQ::Client'; 6 | 7 | my $client = Mojo::RabbitMQ::Client->new(); 8 | 9 | throws_ok { $client->consumer() } qr/is a static method/, 'calling consumer on instance goes fatal'; 10 | throws_ok { $client->publisher() } qr/is a static method/, 'calling publisher on instance goes fatal'; 11 | 12 | lives_and { isa_ok Mojo::RabbitMQ::Client->consumer(), 'Mojo::RabbitMQ::Client::Consumer' }, 'called consumer on package, should live'; 13 | lives_and { isa_ok Mojo::RabbitMQ::Client->publisher(), 'Mojo::RabbitMQ::Client::Publisher' }, 'called publisher on package, should live'; 14 | -------------------------------------------------------------------------------- /t/uri.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More tests => 79; 3 | 4 | my @order = qw(tls user pass host port vhost param); 5 | my @tests = (); 6 | 7 | # Basic tests taken from https://www.rabbitmq.com/uri-spec.html 8 | push @tests, 9 | [ 10 | 'amqp://user:pass@host:10000/vhost', 11 | 0, "user", "pass", "host", "10000", "vhost" 12 | ], 13 | [ 14 | 'amqp://user%61:%61pass@ho%61st:10000/v%2fhost', 15 | 0, "usera", "apass", "hoast", "10000", "v/host" 16 | ], 17 | ['amqp://', 0, undef, undef, "localhost", "5672", "/"], 18 | ['amqp://:@/', 0, "", "", "localhost", "5672", "/"], 19 | ['amqp://user@', 0, "user", undef, "localhost", "5672", "/"], 20 | ['amqp://user:pass@', 0, "user", "pass", "localhost", "5672", "/"], 21 | ['amqp://host', 0, undef, undef, "host", "5672", "/"], 22 | ['amqp://:10000', 0, undef, undef, "localhost", "10000", "/"], 23 | ['amqp:///vhost', 0, undef, undef, "localhost", "5672", "vhost"], 24 | ['amqp://host/', 0, undef, undef, "host", "5672", "/"], 25 | ['amqp://host/%2f', 0, undef, undef, "host", "5672", "/"], 26 | ['amqp://host///', 0, undef, undef, "host", "5672", "//"], 27 | ['amqp://[::1]', 0, undef, undef, "[::1]", "5672", "/"]; 28 | 29 | use_ok 'Mojo::RabbitMQ::Client'; 30 | 31 | foreach my $t (@tests) { 32 | my $idx = 0; 33 | my $url = shift @$t; 34 | 35 | my $client = Mojo::RabbitMQ::Client->new(url => $url); 36 | 37 | for my $v (@$t) { 38 | my $attr = $order[$idx]; 39 | if (ref($v) eq 'HASH') { 40 | foreach my $k (keys %$v) { 41 | my $x = $v->{$k}; 42 | is($client->$attr($k), $x, 43 | "expect $attr($k) to be " . ($x // '(undefined)') . " from $url"); 44 | } 45 | } 46 | else { 47 | is($client->$attr(), $v, 48 | "expect $attr to be " . ($v // '(undefined)') . " from $url"); 49 | } 50 | 51 | $idx++; 52 | } 53 | } 54 | -------------------------------------------------------------------------------- /t/use.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More tests => 7; 3 | 4 | use_ok $_ for qw( 5 | Mojo::RabbitMQ::Client 6 | Mojo::RabbitMQ::Client::Channel 7 | Mojo::RabbitMQ::Client::Consumer 8 | Mojo::RabbitMQ::Client::LocalQueue 9 | Mojo::RabbitMQ::Client::Method 10 | Mojo::RabbitMQ::Client::Method::Publish 11 | Mojo::RabbitMQ::Client::Publisher 12 | ); 13 | -------------------------------------------------------------------------------- /xt/client.t: -------------------------------------------------------------------------------- 1 | use Test::More skip_all => "TODO"; 2 | 3 | subtest 'max_channels' => sub { 4 | 5 | }; 6 | 7 | subtest 'utf-8 on TLS' => sub { 8 | 9 | }; 10 | -------------------------------------------------------------------------------- /xt/consumer.t: -------------------------------------------------------------------------------- 1 | use Test::More skip_all => "TODO"; 2 | 3 | BEGIN { use_ok 'Mojo::RabbitMQ::Client' } 4 | 5 | sub failure { 6 | my ($test, $details) = @_; 7 | fail($test); 8 | diag("Details: " . $details) if $details; 9 | Mojo::IOLoop->stop; 10 | } 11 | 12 | sub handle_error { 13 | my $desc = $_[0] // 'Error'; 14 | return sub { 15 | failure($desc, $_[1]->method_frame->reply_text); 16 | } 17 | } 18 | 19 | my $run_id = time(); 20 | my $exchange_name = 'mrc_test_' . $run_id; 21 | my $queue_name = 'mrc_test_queue' . $run_id; 22 | 23 | my $url = $ENV{MOJO_RABBITMQ_URL} || 'rabbitmq://guest:guest@127.0.0.1:5672/?exchange=' . $exchange_name . '&queue=' . $queue_name; 24 | 25 | Mojo::IOLoop->timer( # Global test timeout 26 | 10 => sub { 27 | failure('Test timeout'); 28 | } 29 | ); 30 | 31 | my $client = Mojo::RabbitMQ::Client->new(url => $url); 32 | $client->catch(handle_error('Connection or other server errors')); 33 | $client->on( 34 | open => sub { 35 | pass('Client connected'); 36 | 37 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 38 | $channel->catch(handle_error("Channel error")); 39 | $channel->on(close => handle_error("Channel error")); 40 | $channel->on( 41 | open => sub { 42 | pass('Channel opened'); 43 | 44 | my $exchange = $channel->declare_exchange( 45 | exchange => $exchange_name, 46 | type => 'topic', 47 | auto_delete => 1, 48 | ); 49 | $exchange->catch(handle_error('Failed to declare exchange')); 50 | $exchange->on( 51 | success => sub { 52 | pass('Exchange declared'); 53 | 54 | my $queue = $channel->declare_queue(queue => $queue_name, 55 | auto_delete => 1,); 56 | $queue->catch(handle_error('Failed to declare queue')); 57 | $queue->on( 58 | success => sub { 59 | pass('Queue declared'); 60 | 61 | my $bind = $channel->bind_queue( 62 | exchange => $exchange_name, 63 | queue => $queue_name, 64 | routing_key => $queue_name, 65 | ); 66 | $bind->catch(handle_error('Failed to bind queue')); 67 | $bind->on( 68 | success => sub { 69 | pass('Queue bound'); 70 | 71 | my $publish = $channel->publish( 72 | exchange => $exchange_name, 73 | routing_key => $queue_name, 74 | body => 'Test message' 75 | ); 76 | $publish->on(success => sub { 77 | pass('Message published'); 78 | start_consumer(); 79 | $client->close(); 80 | }); 81 | $publish->deliver(); 82 | } 83 | ); 84 | $bind->deliver(); 85 | } 86 | ); 87 | $queue->deliver(); 88 | } 89 | ); 90 | $exchange->deliver(); 91 | } 92 | ); 93 | 94 | $client->open_channel($channel); 95 | } 96 | ); 97 | $client->connect(); 98 | 99 | sub start_consumer { 100 | my $consumer = Mojo::RabbitMQ::Client->consumer( 101 | url => $url, 102 | defaults => { 103 | qos => {prefetch_count => 1}, 104 | queue => {auto_delete => 1}, 105 | consumer => {no_ack => 0}, 106 | } 107 | ); 108 | 109 | $consumer->catch(sub { failure('Consumer: Connection or other server errors') }); 110 | $consumer->on(connect => sub { pass('Consumer: Connected to server') }); 111 | $consumer->on( 112 | 'message' => sub { 113 | my ($consumer, $message) = @_; 114 | pass('Consumer: Got message'); 115 | $consumer->close(); 116 | } 117 | ); 118 | $consumer->on(close => sub { pass('Consumer: Disconnected'); Mojo::IOLoop->stop }); 119 | $consumer->start(); 120 | } 121 | 122 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 123 | -------------------------------------------------------------------------------- /xt/pod.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | 3 | use Test::More; 4 | 5 | plan skip_all => 'set TEST_POD to enable this test (developer only!)' 6 | unless $ENV{TEST_POD}; 7 | plan skip_all => 'Test::Pod 1.14+ required for this test!' 8 | unless eval 'use Test::Pod 1.14; 1'; 9 | 10 | all_pod_files_ok(); 11 | -------------------------------------------------------------------------------- /xt/server.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 12; 2 | 3 | BEGIN { use_ok 'Mojo::RabbitMQ::Client' } 4 | 5 | sub failure { 6 | my ($test, $details) = @_; 7 | fail($test); 8 | diag("Details: " . $details) if $details; 9 | Mojo::IOLoop->stop; 10 | } 11 | 12 | my $run_id = time(); 13 | my $exchange_name = 'mrc_test_' . $run_id; 14 | my $queue_name = 'mrc_test_queue' . $run_id; 15 | 16 | my $amqp 17 | = Mojo::RabbitMQ::Client->new( 18 | url => ($ENV{MOJO_RABBITMQ_URL} || 'rabbitmq://guest:guest@127.0.0.1:5672/') 19 | ); 20 | 21 | $amqp->ioloop->timer( # Global test timeout 22 | 10 => sub { 23 | failure('Test timeout'); 24 | } 25 | ); 26 | 27 | $amqp->catch(sub { failure('Connection or other server errors') }); 28 | $amqp->on(connect => sub { pass('Connected to server') }); 29 | $amqp->on( 30 | open => sub { 31 | my ($self) = @_; 32 | 33 | pass('Protocol opened'); 34 | 35 | my $channel = Mojo::RabbitMQ::Client::Channel->new(); 36 | $channel->on( 37 | open => sub { 38 | my ($channel) = @_; 39 | 40 | pass('Channel opened'); 41 | 42 | my $exchange = $channel->declare_exchange( 43 | exchange => $exchange_name, 44 | type => 'topic', 45 | auto_delete => 1, 46 | ); 47 | $exchange->catch(sub { failure('Failed to declare exchange') }); 48 | $exchange->on( 49 | success => sub { 50 | pass('Exchange declared'); 51 | 52 | my $queue = $channel->declare_queue(queue => $queue_name, 53 | auto_delete => 1,); 54 | $queue->catch(sub { failure('Failed to declare queue') }); 55 | $queue->on( 56 | success => sub { 57 | pass('Queue declared'); 58 | 59 | my $bind = $channel->bind_queue( 60 | exchange => $exchange_name, 61 | queue => $queue_name, 62 | routing_key => $queue_name, 63 | ); 64 | $bind->catch(sub { failure('Failed to bind queue') }); 65 | $bind->on( 66 | success => sub { 67 | pass('Queue bound'); 68 | 69 | my $publish = $channel->publish( 70 | exchange => $exchange_name, 71 | routing_key => $queue_name, 72 | body => 'Test message', 73 | mandatory => 0, 74 | immediate => 0, 75 | header => {} 76 | ); 77 | $publish->catch(sub { failure('Message not published') }); 78 | $publish->on( 79 | success => sub { 80 | pass('Message published'); 81 | } 82 | ); 83 | $publish->on(return => sub { failure('Message returned') } 84 | ); 85 | $publish->deliver(); 86 | 87 | my $consumer = $channel->consume(queue => $queue_name,); 88 | $consumer->on( 89 | success => sub { 90 | pass('Subscribed to queue'); 91 | } 92 | ); 93 | $consumer->on( 94 | message => sub { 95 | pass('Got message'); 96 | $amqp->close; 97 | } 98 | ); 99 | $consumer->catch(sub { failure('Subscription failed') }); 100 | $consumer->deliver; 101 | } 102 | ); 103 | $bind->deliver(); 104 | } 105 | ); 106 | $queue->deliver(); 107 | } 108 | ); 109 | $exchange->deliver(); 110 | } 111 | ); 112 | $channel->on(close => 113 | sub { failure('Channel closed', $_[1]->method_frame->reply_text) }); 114 | $channel->catch(sub { failure('Channel error') }); 115 | 116 | $self->open_channel($channel); 117 | } 118 | ); 119 | $amqp->on(close => sub { pass('Connection closed') }); 120 | $amqp->on(disconnect => sub { pass('Disconnected'); Mojo::IOLoop->stop }); 121 | $amqp->connect(); 122 | 123 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 124 | --------------------------------------------------------------------------------