AnyEvent-RabbitMQ-1.19/0000755000175000017500000000000012503322231013575 5ustar daveldavelAnyEvent-RabbitMQ-1.19/xt/0000755000175000017500000000000012503322231014230 5ustar daveldavelAnyEvent-RabbitMQ-1.19/xt/02_perlcritic.t0000644000175000017500000000033312124544652017071 0ustar daveldaveluse strict; use Test::More; eval { require Test::Perl::Critic; Test::Perl::Critic->import( -profile => 'xt/perlcriticrc'); }; plan skip_all => "Test::Perl::Critic is not installed." if $@; all_critic_ok('lib'); AnyEvent-RabbitMQ-1.19/xt/03_pod.t0000644000175000017500000000020112124544652015506 0ustar daveldaveluse Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); AnyEvent-RabbitMQ-1.19/xt/06_close.t0000644000175000017500000000475012503314251016040 0ustar daveldaveluse Test::More; use Test::Exception; my %conf = ( host => 'localhost', port => 5672, user => 'guest', pass => 'guest', vhost => '/', ); eval { use IO::Socket::INET; my $socket = IO::Socket::INET->new( Proto => 'tcp', PeerAddr => $conf{host}, PeerPort => $conf{port}, Timeout => 1, ) or die 'Error connecting to AMQP Server!'; close $socket; }; plan skip_all => 'Connection failure: ' . $conf{host} . ':' . $conf{port} if $@; plan tests => 2; use AnyEvent::RabbitMQ; subtest 'No channels', sub { my $ar = connect_ar(); ok $ar->is_open, 'connection is open'; is channel_count($ar), 0, 'no channels open'; close_ar($ar); ok !$ar->is_open, 'connection closed'; is channel_count($ar), 0, 'no channels open'; }; subtest 'channels', sub { my $ar = connect_ar(); ok $ar->is_open, 'connection is open'; is channel_count($ar), 0, 'no channels open'; my $ch = open_channel($ar); ok $ch->is_open, 'channel is open'; is channel_count($ar), 1, 'no channels open'; close_ar($ar); ok !$ar->is_open, 'connection closed'; is channel_count($ar), 0, 'no channels open'; ok !$ch->is_open, 'channel closed'; }; sub connect_ar { my $done = AnyEvent->condvar; my $ar = AnyEvent::RabbitMQ->new()->load_xml_spec()->connect( (map {$_ => $conf{$_}} qw(host port user pass vhost)), timeout => 1, on_success => sub {$done->send(1)}, on_failure => sub { diag @_; $done->send()}, on_close => \&handle_close, ); die 'Connection failure' if !$done->recv; return $ar; } sub close_ar { my ($ar,) = @_; my $done = AnyEvent->condvar; $ar->close( on_success => sub {$done->send(1)}, on_failure => sub { diag @_; $done->send()}, ); die 'Close failure' if !$done->recv; return; } sub channel_count { my ($ar,) = @_; return scalar keys %{$ar->channels}; } sub open_channel { my ($ar,) = @_; my $done = AnyEvent->condvar; $ar->open_channel( on_success => sub {$done->send(shift)}, on_failure => sub {$done->send()}, on_return => sub {die 'Receive return'}, on_close => \&handle_close, ); my $ch = $done->recv; die 'Open channel failure' if !$ch; return $ch; } sub handle_close { my $method_frame = shift->method_frame; die $method_frame->reply_code, $method_frame->reply_text if $method_frame->reply_code; } AnyEvent-RabbitMQ-1.19/xt/perlcriticrc0000644000175000017500000000033712124544652016657 0ustar daveldavel[TestingAndDebugging::ProhibitNoStrict] allow=refs [TestingAndDebugging::RequireUseStrict] equivalent_modules = Any::Moose Moose Mouse [TestingAndDebugging::RequireUseWarnings] equivalent_modules = Any::Moose Moose Mouse AnyEvent-RabbitMQ-1.19/xt/05_multi_channel.t0000644000175000017500000000742012503314251017551 0ustar daveldaveluse Test::More; use Test::Exception; my %conf = ( host => 'localhost', port => 5672, user => 'guest', pass => 'guest', vhost => '/', ); eval { use IO::Socket::INET; my $socket = IO::Socket::INET->new( Proto => 'tcp', PeerAddr => $conf{host}, PeerPort => $conf{port}, Timeout => 1, ) or die 'Error connecting to AMQP Server!'; close $socket; }; plan skip_all => 'Connection failure: ' . $conf{host} . ':' . $conf{port} if $@; plan tests => 3; use AnyEvent::RabbitMQ; my $ar = connect_ar(); my @queues = map { my $ch = open_channel($ar); my $queue = 'test_q' . $_; declare_queue($ch, $queue,); my $done = AnyEvent->condvar; my $cdone = AnyEvent->condvar; consume($ch, $queue, sub { my $response = shift; return if 'stop' ne $response->{body}->payload; $done->send(); }, sub { $cdone->send(); }); {name => $queue, cv => $done, ccv => $cdone}; } (1..5); pass('queue setup'); my $ch = open_channel($ar); for my $queue (@queues) { publish($ch, $queue->{name}, 'hello'); publish($ch, $queue->{name}, 'stop'); } my $count = 0; for my $queue (@queues) { $queue->{cv}->recv; $count++; } is($count, 5, 'consume count'); for my $queue (@queues) { delete_queue($ch, $queue->{name}); } my $ccount = 0; for my $queue (@queues) { $queue->{ccv}->recv; $ccount++; } is($ccount, 5, 'cancel count'); close_ar($ar); sub connect_ar { my $done = AnyEvent->condvar; my $ar = AnyEvent::RabbitMQ->new()->load_xml_spec()->connect( (map {$_ => $conf{$_}} qw(host port user pass vhost)), timeout => 1, on_success => sub {$done->send(1)}, on_failure => sub { diag @_; $done->send()}, on_close => \&handle_close, ); die 'Connection failure' if !$done->recv; return $ar; } sub close_ar { my ($ar,) = @_; my $done = AnyEvent->condvar; $ar->close( on_success => sub {$done->send(1)}, on_failure => sub { diag @_; $done->send()}, ); die 'Close failure' if !$done->recv; return; } sub open_channel { my ($ar,) = @_; my $done = AnyEvent->condvar; $ar->open_channel( on_success => sub {$done->send(shift)}, on_failure => sub {$done->send()}, on_return => sub {die 'Receive return'}, on_close => \&handle_close, ); my $ch = $done->recv; die 'Open channel failure' if !$ch; return $ch; } sub declare_queue { my ($ch, $queue,) = @_; my $done = AnyEvent->condvar; $ch->declare_queue( queue => $queue, on_success => sub {$done->send(1)}, on_failure => sub {$done->send()}, ); die 'Declare queue failure' if !$done->recv; return; } sub delete_queue { my ($ch, $queue,) = @_; my $done = AnyEvent->condvar; $ch->delete_queue( queue => $queue, on_success => sub {$done->send(1)}, on_failure => sub {$done->send()}, ); die 'Delete queue failure' if !$done->recv; return; } sub consume { my ($ch, $queue, $handle_consume, $handle_cancel,) = @_; my $done = AnyEvent->condvar; $ch->consume( queue => $queue, on_success => sub {$done->send(1)}, on_failure => sub {$done->send()}, on_consume => $handle_consume, on_cancel => $handle_cancel, ); die 'Consume failure' if !$done->recv; return; } sub publish { my ($ch, $queue, $message,) = @_; $ch->publish( routing_key => $queue, body => $message, mandatory => 1, ); return; } sub handle_close { my $method_frame = shift->method_frame; die $method_frame->reply_code, $method_frame->reply_text if $method_frame->reply_code; } AnyEvent-RabbitMQ-1.19/xt/01_podspell.t0000644000175000017500000000051412124544652016553 0ustar daveldaveluse Test::More; eval q{ use Test::Spelling }; plan skip_all => "Test::Spelling is not installed." if $@; add_stopwords(map { split /[\s\:\-]/ } ); set_spell_cmd('aspell list'); $ENV{LANG} = 'C'; all_pod_files_spelling_ok('lib'); __DATA__ API signalled cancelled Masahito Ikuta cooldaemon@gmail.com AMQP RabbitMQ multi ack qos AnyEvent-RabbitMQ-1.19/xt/04_anyevent.t0000644000175000017500000003057612503314251016567 0ustar daveldaveluse Test::More; use Test::Exception; use Data::Dumper; use FindBin; my %server = ( product => undef, version => undef, ); my %conf = ( host => 'localhost', port => 5672, user => 'guest', pass => 'guest', vhost => '/', # verbose => 1, ); eval { use IO::Socket::INET; my $socket = IO::Socket::INET->new( Proto => 'tcp', PeerAddr => $conf{host}, PeerPort => $conf{port}, Timeout => 1, ) or die 'Error connecting to AMQP Server!'; close $socket; }; plan skip_all => 'Connection failure: ' . $conf{host} . ':' . $conf{port} if $@; use AnyEvent::RabbitMQ; my $ar = AnyEvent::RabbitMQ->new(verbose => $conf{verbose}); lives_ok sub { $ar->load_xml_spec() }, 'load xml spec'; my $done = AnyEvent->condvar; $ar->connect( (map {$_ => $conf{$_}} qw(host port user pass vhost)), tune => { frame_max => 2**17 }, timeout => 1, on_success => sub { my $ar = shift; isa_ok($ar, 'AnyEvent::RabbitMQ'); $server{product} = $ar->server_properties->{product}; $server{version} = version->parse($ar->server_properties->{version}); $done->send; }, on_failure => failure_cb($done), on_return => sub { my $method_frame = shift->method_frame; die "return: ", $method_frame->reply_code, $method_frame->reply_text if $method_frame->reply_code; }, on_close => sub { my $method_frame = shift->method_frame; Carp::confess "close: ", $method_frame->reply_code, $method_frame->reply_text if $method_frame->reply_code; }, ); $done->recv; my $ch; $done = AnyEvent->condvar; open_ch($done); $done->recv; sub open_ch { my ($cv,) = @_; $ar->open_channel( on_success => sub { $ch = shift; isa_ok($ch, 'AnyEvent::RabbitMQ::Channel'); $cv->send; }, on_failure => failure_cb($cv), on_close => sub { my $method_frame = shift->method_frame; die $method_frame->reply_code, $method_frame->reply_text if $method_frame->reply_code; }, ); } $done = AnyEvent->condvar; $ch->declare_exchange( exchange => 'test_x', on_success => sub { pass('declare exchange'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; $ch->declare_exchange( exchange => 'test_x_dest', on_success => sub { pass('declare destination exchange'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; $ch->bind_exchange( source => 'test_x', destination => 'test_x_dest', on_success => sub { pass('bind exchange -> dest'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; $ch->declare_queue( queue => 'test_q', on_success => sub { pass('declare queue'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; $ch->bind_queue( queue => 'test_q', exchange => 'test_x', routing_key => 'test_r', on_success => sub { pass('bound queue'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; my $consumer_tag; $ch->consume( queue => 'test_q', on_success => sub { my $frame = shift; $consumer_tag = $frame->method_frame->consumer_tag; pass('consume'); }, on_consume => sub { my $response = shift; ok($response->{body}->payload, 'publish'); $done->send; }, on_failure => failure_cb($done), ); publish($ch, 'Hello RabbitMQ.', $done,); $done->recv; $done = AnyEvent->condvar; $ch->cancel( consumer_tag => $consumer_tag, on_success => sub { pass('cancel'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; publish($ch, 'I love RabbitMQ.', $done,); $ch->get( queue => 'test_q', on_success => sub { my $response = shift; ok(defined $response->{ok}, 'getok'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; $ch->get( queue => 'test_q', on_success => sub { my $response = shift; ok(defined $response->{empty}, 'empty'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; for my $size (10, 131_064, 10, 140_000) { send_large_size_message($ch, $size); } $done = AnyEvent->condvar; $ch->consume( queue => 'test_q', no_ack => 0, on_consume => sub { my $response = shift; $ch->ack( delivery_tag => $response->{deliver}->method_frame->delivery_tag ); pass('ack deliver'); $ch->cancel( consumer_tag => $response->{deliver}->method_frame->consumer_tag, on_success => sub { pass('cancel'); $done->send; }, on_failure => failure_cb($done), ); }, on_failure => failure_cb($done), ); publish($ch, 'NO RabbitMQ, NO LIFE.', $done,); $done->recv; $done = AnyEvent->condvar; publish($ch, 'RabbitMQ is cool.', $done,); $ch->get( queue => 'test_q', no_ack => 0, on_success => sub { my $response = shift; $ch->ack( delivery_tag => $response->{ok}->method_frame->delivery_tag ); pass('ack get'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; my @responses; $ch->qos( prefetch_count => 2, on_success => sub { $ch->consume( queue => 'test_q', no_ack => 0, on_consume => sub { my $response = shift; push @responses, $response; return if 2 > scalar @responses; $done->send; }, on_failure => failure_cb($done), ); }, on_failure => failure_cb($done), ); publish($ch, 'RabbitMQ is excellent.', $done,); publish($ch, 'RabbitMQ is fantastic.', $done,); $done->recv; pass('qos'); for my $response (@responses) { $ch->ack( delivery_tag => $response->{deliver}->method_frame->delivery_tag, ); } $done = AnyEvent->condvar; $ch->cancel( consumer_tag => $responses[0]->{deliver}->method_frame->consumer_tag, on_success => sub { $ch->qos( on_success => sub { $done->send; }, on_failure => failure_cb($done), ); }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; my $recover_count = 0; $ch->consume( queue => 'test_q', no_ack => 0, on_consume => sub { my $response = shift; if (5 > ++$recover_count) { $ch->recover(); return; } $ch->ack( delivery_tag => $response->{deliver}->method_frame->delivery_tag ); $ch->cancel( consumer_tag => $response->{deliver}->method_frame->consumer_tag, on_success => sub { $done->send; }, on_failure => failure_cb($done), ); }, on_failure => failure_cb($done), ); publish($ch, 'RabbitMQ is powerful.', $done,); $done->recv; pass('recover'); # This only works for RabbitMQ >= 2.0.0 my $can_reject = $server{product} eq 'RabbitMQ' && $server{version} >= version->parse('2.0.0'); SKIP: { skip 'We need RabbitMQ >= 2.0.0 for the confirm and reject test', 1 unless $can_reject; $done = AnyEvent->condvar; $ch->confirm( on_success => sub { $done->send }, on_failure => failure_cb($done), ); $done->recv; pass('confirm'); $done = AnyEvent->condvar; my $reject_count = 0; $ch->consume( queue => 'test_q', no_ack => 0, on_consume => sub { my $response = shift; if ( 5 > ++$reject_count ) { $ch->reject( delivery_tag => $response->{deliver}->method_frame->delivery_tag, # requeue! Else the server does not deliver the message again to this client. requeue => 1, ); return; } $ch->ack( delivery_tag => $response->{deliver}->method_frame->delivery_tag ); $ch->cancel( consumer_tag => $response->{deliver}->method_frame->consumer_tag, on_success => sub { $done->send; }, on_failure => failure_cb($done), ); }, on_failure => failure_cb($done), ); my $pub_done = AnyEvent->condvar; publish($ch, 'RabbitMQ is powerful.', $pub_done,); $pub_done->recv; $done->recv; pass('reject'); # reopen because confirm is not compatible with transactions $done = AnyEvent->condvar; $ch->close( on_success => sub { pass('close2'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; undef $ch; $done = AnyEvent->condvar; open_ch($done); $done->recv; pass('open2'); }; $done = AnyEvent->condvar; $ch->select_tx( on_success => sub { pass('select tx'); publish($ch, 'RabbitMQ is highly reliable systems.', $done,); $ch->rollback_tx( on_success => sub { pass('rollback tx'); publish($ch, 'RabbitMQ is highly reliable systems.', $done,); $ch->commit_tx( on_success => sub { pass('commit tx'); $done->send; }, on_failure => failure_cb($done), ); }, on_failure => failure_cb($done), ); }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; $ch->purge_queue( queue => 'test_q', on_success => sub { pass('purge queue'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; $ch->unbind_queue( queue => 'test_q', exchange => 'test_x', routing_key => 'test_r', on_success => sub { pass('unbind queue'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; $ch->delete_queue( queue => 'test_q', on_success => sub { pass('delete queue'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; $ch->unbind_exchange( source => 'test_x', destination => 'test_x_dest', on_success => sub { pass('unbind exchange'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; $ch->delete_exchange( exchange => 'test_x', on_success => sub { pass('delete exchange'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; $ch->delete_exchange( exchange => 'test_x_dest', on_success => sub { pass('delete destination exchange'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; $done = AnyEvent->condvar; $ar->close( on_success => sub { pass('close2'); $done->send; }, on_failure => failure_cb($done), ); $done->recv; sub failure_cb { my ($cv,) = @_; return sub { fail(join(' ', 'on_failure:', @_)); $cv->send; }; } sub publish { my ($ch, $message, $cv,) = @_; $ch->publish( exchange => 'test_x', routing_key => 'test_r', body => $message, on_ack => sub { $cv->send }, on_return => sub { my $response = shift; fail('on_return: ' . Dumper($response)); $cv->send; }, ); return; } sub send_large_size_message { my ($ch, $size,) = @_; my $done = AnyEvent->condvar; publish($ch, 'a' x $size, $done,); $ch->get( queue => 'test_q', on_success => sub { my $response = shift; is(length($response->{body}->payload), $size, 'get large size: ' . $size); $done->send; }, on_failure => failure_cb($done), ); $done->recv; return; } done_testing; AnyEvent-RabbitMQ-1.19/MANIFEST0000644000175000017500000000122312503322224014726 0ustar daveldavelChanges inc/Module/Install.pm inc/Module/Install/AuthorTests.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Share.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/AnyEvent/RabbitMQ.pm lib/AnyEvent/RabbitMQ/Channel.pm lib/AnyEvent/RabbitMQ/LocalQueue.pm Makefile.PL MANIFEST This list of files META.yml README share/fixed_amqp0-8.xml share/fixed_amqp0-9-1.xml share/README t/00_compile.t t/01_localqueue.t xt/01_podspell.t xt/02_perlcritic.t xt/03_pod.t xt/04_anyevent.t xt/05_multi_channel.t xt/06_close.t xt/perlcriticrc AnyEvent-RabbitMQ-1.19/lib/0000755000175000017500000000000012503322231014343 5ustar daveldavelAnyEvent-RabbitMQ-1.19/lib/AnyEvent/0000755000175000017500000000000012503322231016074 5ustar daveldavelAnyEvent-RabbitMQ-1.19/lib/AnyEvent/RabbitMQ.pm0000644000175000017500000005057612503320672020117 0ustar daveldavelpackage AnyEvent::RabbitMQ; use strict; use warnings; use Carp qw(confess croak); use Scalar::Util qw(refaddr); use List::MoreUtils qw(none); use Devel::GlobalDestruction; use File::ShareDir; use Readonly; use Scalar::Util qw/ weaken /; require Data::Dumper; sub Dumper { local $Data::Dumper::Terse = 1; local $Data::Dumper::Indent = 1; local $Data::Dumper::Useqq = 1; local $Data::Dumper::Deparse = 1; local $Data::Dumper::Quotekeys = 0; local $Data::Dumper::Sortkeys = 1; &Data::Dumper::Dumper } use AnyEvent::Handle; use AnyEvent::Socket; use Net::AMQP 0.06; use Net::AMQP::Common qw(:all); use AnyEvent::RabbitMQ::Channel; use AnyEvent::RabbitMQ::LocalQueue; use namespace::clean; our $VERSION = '1.19'; use constant { _ST_CLOSED => 0, _ST_OPENING => 1, _ST_OPEN => 2, _ST_CLOSING => 3, }; Readonly my $DEFAULT_AMQP_SPEC => File::ShareDir::dist_dir("AnyEvent-RabbitMQ") . '/fixed_amqp0-9-1.xml'; Readonly my $DEFAULT_CHANNEL_MAX => 2**16; sub new { my $class = shift; return bless { verbose => 0, @_, _state => _ST_CLOSED, _queue => AnyEvent::RabbitMQ::LocalQueue->new, _last_chan_id => 0, _channels => {}, _login_user => '', _server_properties => {}, _frame_max => undef, _body_max => undef, _channel_max => undef, }, $class; } sub verbose { my $self = shift; @_ ? ($self->{verbose} = shift) : $self->{verbose} } sub is_open { my $self = shift; $self->{_state} == _ST_OPEN } sub channels { my $self = shift; return $self->{_channels}; } sub _delete_channel { my $self = shift; my ($channel,) = @_; my $c = $self->{_channels}->{$channel->id}; if (defined($c) && refaddr($c) == refaddr($channel)) { delete $self->{_channels}->{$channel->id}; return 1; } return 0; } sub login_user { my $self = shift; return $self->{_login_user}; } my $_loaded_spec; sub load_xml_spec { my $self = shift; my ($spec) = @_; $spec ||= $DEFAULT_AMQP_SPEC; if ($_loaded_spec && $_loaded_spec ne $spec) { croak("Tried to load AMQP spec $spec, but have already loaded $_loaded_spec, not possible"); } elsif (!$_loaded_spec) { Net::AMQP::Protocol->load_xml_spec($_loaded_spec = $spec); } return $self; } sub connect { my $self = shift; my %args = $self->_set_cbs(@_); if ($self->{_state} != _ST_CLOSED) { $args{on_failure}->('Connection has already been opened'); return $self; } $args{on_close} ||= sub {}; $args{on_read_failure} ||= sub {warn @_, "\n"}; $args{timeout} ||= 0; for (qw/ host port /) { $args{$_} or return $args{on_failure}->("No $_ passed to connect"); } if ($self->{verbose}) { warn 'connect to ', $args{host}, ':', $args{port}, '...', "\n"; } $self->{_state} = _ST_OPENING; weaken(my $weak_self = $self); my $conn; $conn = AnyEvent::Socket::tcp_connect( $args{host}, $args{port}, sub { undef $conn; my $self = $weak_self or return; my $fh = shift or return $args{on_failure}->( sprintf('Error connecting to AMQP Server %s:%s: %s', $args{host}, $args{port}, $!) ); my $close_cb = $args{on_close}; my $failure_cb = $args{on_failure}; $self->{_handle} = AnyEvent::Handle->new( fh => $fh, on_error => sub { my ($handle, $fatal, $message) = @_; my $self = $weak_self or return; if ($self->is_open) { $self->_server_closed($close_cb, $message); } else { $failure_cb->(@_); } }, on_drain => sub { my ($handle) = @_; my $self = $weak_self or return; $self->{drain_condvar}->send if exists $self->{drain_condvar}; }, $args{tls} ? (tls => 'connect') : (), ); $self->_read_loop($args{on_close}, $args{on_read_failure}); $self->_start(%args,); }, sub { return $args{timeout}; }, ); return $self; } sub server_properties { return shift->{_server_properties}; } sub _read_loop { my ($self, $close_cb, $failure_cb,) = @_; return if !defined $self->{_handle}; # called on_error weaken(my $weak_self = $self); $self->{_handle}->push_read(chunk => 8, sub { my $self = $weak_self or return; my $data = $_[1]; my $stack = $_[1]; if (length($data) <= 7) { $failure_cb->('Broken data was received'); @_ = ($self, $close_cb, $failure_cb,); goto &_read_loop; } my ($type_id, $channel, $length,) = unpack 'CnN', substr $data, 0, 7, ''; if (!defined $type_id || !defined $channel || !defined $length) { $failure_cb->('Broken data was received'); @_ = ($self, $close_cb, $failure_cb,); goto &_read_loop; } $self->{_handle}->push_read(chunk => $length, sub { my $self = $weak_self or return; $stack .= $_[1]; my ($frame) = Net::AMQP->parse_raw_frames(\$stack); $self->{_heartbeat_recv} = time if $self->{_heartbeat_timer}; if ($self->{verbose}) { warn '[C] <-- [S] ', Dumper($frame), '-----------', "\n"; } my $id = $frame->channel; if (0 == $id) { if ($frame->type_id == 8) { # Heartbeat, no action needs taking. } else { return unless $self->_check_close_and_clean($frame, $close_cb,); $self->{_queue}->push($frame); } } else { my $channel = $self->{_channels}->{$id}; if (defined $channel) { $channel->push_queue_or_consume($frame, $failure_cb); } else { $failure_cb->('Unknown channel id: ' . $frame->channel); } } @_ = ($self, $close_cb, $failure_cb,); goto &_read_loop; }); }); return $self; } sub _check_close_and_clean { my $self = shift; my ($frame, $close_cb,) = @_; my $method_frame = $frame->isa('Net::AMQP::Frame::Method') ? $frame->method_frame : undef; if ($self->{_state} == _ST_CLOSED) { return $method_frame && $method_frame->isa('Net::AMQP::Protocol::Connection::CloseOk'); } if ($method_frame && $method_frame->isa('Net::AMQP::Protocol::Connection::Close')) { delete $self->{_heartbeat_timer}; $self->_push_write(Net::AMQP::Protocol::Connection::CloseOk->new()); $self->_server_closed($close_cb, $frame); return; } return 1; } sub _server_closed { my $self = shift; my ($close_cb, $why,) = @_; $self->{_state} = _ST_CLOSING; for my $channel (values %{ $self->{_channels} }) { $channel->_closed(ref($why) ? $why : $channel->_close_frame($why)); } $self->{_channels} = {}; $self->{_handle}->push_shutdown; $self->{_state} = _ST_CLOSED; $close_cb->($why); return; } sub _start { my $self = shift; my %args = @_; if ($self->{verbose}) { warn 'post header', "\n"; } $self->{_handle}->push_write(Net::AMQP::Protocol->header); $self->_push_read_and_valid( 'Connection::Start', sub { my $frame = shift; my @mechanisms = split /\s/, $frame->method_frame->mechanisms; return $args{on_failure}->('AMQPLAIN is not found in mechanisms') if none {$_ eq 'AMQPLAIN'} @mechanisms; my @locales = split /\s/, $frame->method_frame->locales; return $args{on_failure}->('en_US is not found in locales') if none {$_ eq 'en_US'} @locales; $self->{_server_properties} = $frame->method_frame->server_properties; $self->_push_write( Net::AMQP::Protocol::Connection::StartOk->new( client_properties => { platform => 'Perl', product => __PACKAGE__, information => 'http://d.hatena.ne.jp/cooldaemon/', version => Net::AMQP::Value::String->new(__PACKAGE__->VERSION), capabilities => { consumer_cancel_notify => Net::AMQP::Value::true, exchange_exchange_bindings => Net::AMQP::Value::true, }, %{ $args{client_properties} || {} }, }, mechanism => 'AMQPLAIN', response => { LOGIN => $args{user}, PASSWORD => $args{pass}, }, locale => 'en_US', ), ); $self->_tune(%args,); }, $args{on_failure}, ); return $self; } sub _tune { my $self = shift; my %args = @_; weaken(my $weak_self = $self); $self->_push_read_and_valid( 'Connection::Tune', sub { my $self = $weak_self or return; my $frame = shift; my %tune; foreach (qw( channel_max frame_max heartbeat )) { my $client = $args{tune}{$_} || 0; my $server = $frame->method_frame->$_ || 0; # negotiate with the server such that we cannot request a larger # value set by the server, unless the server said unlimited $tune{$_} = ($server == 0 or $client == 0) ? ($server > $client ? $server : $client) # max : ($client > $server ? $server : $client); # min } if ($self->{_frame_max} = $tune{frame_max}) { # calculate how big the body can actually be $self->{_body_max} = $self->{_frame_max} - Net::AMQP::_HEADER_LEN - Net::AMQP::_FOOTER_LEN; } $self->{_channel_max} = $tune{channel_max} || $DEFAULT_CHANNEL_MAX; $self->_push_write( Net::AMQP::Protocol::Connection::TuneOk->new(%tune,) ); if ($tune{heartbeat} > 0) { $self->_start_heartbeat($tune{heartbeat}, %args,); } $self->_open(%args,); }, $args{on_failure}, ); return $self; } sub _start_heartbeat { my ($self, $interval, %args,) = @_; my $close_cb = $args{on_close}; my $failure_cb = $args{on_read_failure}; my $last_recv = 0; my $idle_cycles = 0; weaken(my $weak_self = $self); my $timer_cb = sub { my $self = $weak_self or return; if ($self->{_heartbeat_recv} != $last_recv) { $last_recv = $self->{_heartbeat_recv}; $idle_cycles = 0; } elsif (++$idle_cycles > 1) { delete $self->{_heartbeat_timer}; $failure_cb->("Heartbeat lost"); $self->_server_closed($close_cb, "Heartbeat lost"); return; } $self->_push_write(Net::AMQP::Frame::Heartbeat->new()); }; $self->{_heartbeat_recv} = time; $self->{_heartbeat_timer} = AnyEvent->timer( after => $interval, interval => $interval, cb => $timer_cb, ); return $self; } sub _open { my $self = shift; my %args = @_; $self->_push_write_and_read( 'Connection::Open', { virtual_host => $args{vhost}, insist => 1, }, 'Connection::OpenOk', sub { $self->{_state} = _ST_OPEN; $self->{_login_user} = $args{user}; $args{on_success}->($self); }, $args{on_failure}, ); return $self; } sub close { return if in_global_destruction; my $self = shift; my %args = $self->_set_cbs(@_); if ($self->{_state} == _ST_CLOSED) { $args{on_success}->(@_); return $self; } if ($self->{_state} != _ST_OPEN) { $args{on_failure}->(($self->{_state} == _ST_OPENING ? "open" : "close") . " already in progress"); return $self; } $self->{_state} = _ST_CLOSING; my $cv = AE::cv { delete $self->{_closing}; $self->_finish_close(%args); }; $cv->begin(); my @ids = keys %{$self->{_channels}}; for my $id (@ids) { my $channel = $self->{_channels}->{$id}; if ($channel->is_open) { $cv->begin(); $channel->close( on_success => sub { $cv->end() }, on_failure => sub { $cv->end() }, ); } } $cv->end(); return $self; } sub _finish_close { my $self = shift; my %args = @_; if (my @ch = map { $_->id } grep { defined() && $_->is_open } values %{$self->{_channels}}) { $args{on_failure}->("BUG: closing with channel(s) open: @ch"); return; } $self->{_state} = _ST_CLOSED; $self->_push_write_and_read( 'Connection::Close', {}, 'Connection::CloseOk', sub { # circular ref ok $self->{_handle}->push_shutdown; $args{on_success}->(@_); }, sub { # circular ref ok $self->{_handle}->push_shutdown; $args{on_failure}->(@_); }, ); return; } sub open_channel { my $self = shift; my %args = $self->_set_cbs(@_); return $self if !$self->_check_open($args{on_failure}); $args{on_close} ||= sub {}; my $id = $args{id}; if ($id && $self->{_channels}->{$id}) { $args{on_failure}->("Channel id $id is already in use"); return $self; } if (!$id) { my $try_id = $self->{_last_chan_id}; for (1 .. $self->{_channel_max}) { $try_id = 1 if ++$try_id > $self->{_channel_max}; unless (defined $self->{_channels}->{$try_id}) { $id = $try_id; last; } } if (!$id) { $args{on_failure}->('Ran out of channel ids'); return $self; } $self->{_last_chan_id} = $id; } my $channel = AnyEvent::RabbitMQ::Channel->new( id => $id, connection => $self, on_close => $args{on_close}, ); $self->{_channels}->{$id} = $channel; $channel->open( on_success => sub { $args{on_success}->($channel); }, on_failure => sub { $self->_delete_channel($channel); $args{on_failure}->(@_); }, ); return $self; } sub _push_write_and_read { my $self = shift; my ($method, $args, $exp, $cb, $failure_cb, $id,) = @_; $method = 'Net::AMQP::Protocol::' . $method; $self->_push_write( Net::AMQP::Frame::Method->new( method_frame => $method->new(%$args) ), $id, ); return $self->_push_read_and_valid($exp, $cb, $failure_cb, $id,); } sub _push_read_and_valid { my $self = shift; my ($exp, $cb, $failure_cb, $id,) = @_; $exp = ref($exp) eq 'ARRAY' ? $exp : [$exp]; my $queue; if (!$id) { $queue = $self->{_queue}; } elsif (defined $self->{_channels}->{$id}) { $queue = $self->{_channels}->{$id}->queue; } else { $failure_cb->('Unknown channel id: ' . $id); } return unless $queue; # Can go away in global destruction.. $queue->get(sub { my $frame = shift; return $failure_cb->('Received data is not method frame') if !$frame->isa('Net::AMQP::Frame::Method'); my $method_frame = $frame->method_frame; for my $exp_elem (@$exp) { return $cb->($frame) if $method_frame->isa('Net::AMQP::Protocol::' . $exp_elem); } $failure_cb->( $method_frame->isa('Net::AMQP::Protocol::Channel::Close') ? 'Channel closed' : 'Expected ' . join(',', @$exp) . ' but got ' . ref($method_frame) ); }); } sub _push_write { my $self = shift; my ($output, $id,) = @_; if ($output->isa('Net::AMQP::Protocol::Base')) { $output = $output->frame_wrap; } $output->channel($id || 0); if ($self->{verbose}) { warn '[C] --> [S] ', Dumper($output); } $self->{_handle}->push_write($output->to_raw_frame()) if $self->{_handle}; # Careful - could have gone (global destruction) return; } sub _set_cbs { my $self = shift; my %args = @_; $args{on_success} ||= sub {}; $args{on_failure} ||= sub { die @_ unless in_global_destruction }; return %args; } sub _check_open { my $self = shift; my ($failure_cb) = @_; return 1 if $self->is_open; $failure_cb->('Connection has already been closed'); return 0; } sub drain_writes { my ($self, $timeout) = shift; $self->{drain_condvar} = AnyEvent->condvar; if ($timeout) { $self->{drain_timer} = AnyEvent->timer( after => $timeout, sub { $self->{drain_condvar}->croak("Timed out after $timeout"); }); } $self->{drain_condvar}->recv; delete $self->{drain_timer}; } sub DESTROY { my $self = shift; $self->close() unless in_global_destruction; return; } 1; __END__ =head1 NAME AnyEvent::RabbitMQ - An asynchronous and multi channel Perl AMQP client. =head1 SYNOPSIS use AnyEvent::RabbitMQ; my $cv = AnyEvent->condvar; my $ar = AnyEvent::RabbitMQ->new->load_xml_spec()->connect( host => 'localhost', port => 5672, user => 'guest', pass => 'guest', vhost => '/', timeout => 1, tls => 0, # Or 1 if you'd like SSL tune => { heartbeat => 30, channel_max => $whatever, frame_max = $whatever }, on_success => sub { my $ar = shift; $ar->open_channel( on_success => sub { my $channel = shift; $channel->declare_exchange( exchange => 'test_exchange', on_success => sub { $cv->send('Declared exchange'); }, on_failure => $cv, ); }, on_failure => $cv, on_close => sub { my $method_frame = shift->method_frame; die $method_frame->reply_code, $method_frame->reply_text; }, ); }, on_failure => $cv, on_read_failure => sub { die @_ }, on_return => sub { my $frame = shift; die "Unable to deliver ", Dumper($frame); }, on_close => sub { my $why = shift; if (ref($why)) { my $method_frame = $why->method_frame; die $method_frame->reply_code, ": ", $method_frame->reply_text; } else { die $why; } }, ); print $cv->recv, "\n"; =head1 DESCRIPTION AnyEvent::RabbitMQ is an AMQP(Advanced Message Queuing Protocol) client library, that is intended to allow you to interact with AMQP-compliant message brokers/servers such as RabbitMQ in an asynchronous fashion. You can use AnyEvent::RabbitMQ to - * Declare and delete exchanges * Declare, delete, bind and unbind queues * Set QoS and confirm mode * Publish, consume, get, ack, recover and reject messages * Select, commit and rollback transactions Most of these actions can be done through L. Please see the documentation there for more details. AnyEvent::RabbitMQ is known to work with RabbitMQ versions 2.5.1 and versions 0-8 and 0-9-1 of the AMQP specification. This client is the non-blocking version, for a blocking version with a similar API, see L. =head1 AUTHOR Masahito Ikuta Ecooldaemon@gmail.comE =head1 MAINTAINER Currently maintained by C<< >> due to the original author being missing in action. =head1 COPYRIGHT Copyright (c) 2010, the above named author(s). =head1 SEE ALSO =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut AnyEvent-RabbitMQ-1.19/lib/AnyEvent/RabbitMQ/0000755000175000017500000000000012503322231017535 5ustar daveldavelAnyEvent-RabbitMQ-1.19/lib/AnyEvent/RabbitMQ/LocalQueue.pm0000644000175000017500000000217212503314251022137 0ustar daveldavelpackage AnyEvent::RabbitMQ::LocalQueue; use strict; use warnings; our $VERSION = '1.16'; sub new { my $class = shift; return bless { _message_queue => [], _drain_code_queue => [], }, $class; } sub push { my $self = shift; CORE::push @{$self->{_message_queue}}, @_; return $self->_drain_queue(); } sub get { my $self = shift; CORE::push @{$self->{_drain_code_queue}}, @_; return $self->_drain_queue(); } sub _drain_queue { my $self = shift; my $message_count = scalar @{$self->{_message_queue}}; my $drain_code_count = scalar @{$self->{_drain_code_queue}}; my $count = $message_count < $drain_code_count ? $message_count : $drain_code_count; for (1 .. $count) { &{shift @{$self->{_drain_code_queue}}}( shift @{$self->{_message_queue}} ); } return $self; } sub _flush { my ($self, $frame) = @_; $self->_drain_queue; while (my $cb = shift @{$self->{_drain_code_queue}}) { local $@; # Flush frames immediately, throwing away errors for on-close eval { $cb->($frame) }; } } 1; AnyEvent-RabbitMQ-1.19/lib/AnyEvent/RabbitMQ/Channel.pm0000644000175000017500000007772012503320020021452 0ustar daveldavelpackage AnyEvent::RabbitMQ::Channel; use strict; use warnings; use AnyEvent::RabbitMQ::LocalQueue; use AnyEvent; use Scalar::Util qw( looks_like_number weaken ); use Devel::GlobalDestruction; use Carp qw(croak); use POSIX qw(ceil); BEGIN { *Dumper = \&AnyEvent::RabbitMQ::Dumper } use namespace::clean; use constant { _ST_CLOSED => 0, _ST_OPENING => 1, _ST_OPEN => 2, }; our $VERSION = '1.16'; sub new { my $class = shift; my $self = bless { on_close => sub {}, @_, # id, connection, on_return, on_close, on_inactive, on_active _queue => AnyEvent::RabbitMQ::LocalQueue->new, _content_queue => AnyEvent::RabbitMQ::LocalQueue->new, }, $class; weaken($self->{connection}); return $self->_reset; } sub _reset { my $self = shift; my %a = ( _state => _ST_CLOSED, _is_active => 0, _is_confirm => 0, _publish_tag => 0, _publish_cbs => {}, # values: [on_ack, on_nack, on_return] _consumer_cbs => {}, # values: [on_consume, on_cancel...] ); @$self{keys %a} = values %a; return $self; } sub id { my $self = shift; return $self->{id}; } sub is_open { my $self = shift; return $self->{_state} == _ST_OPEN; } sub is_active { my $self = shift; return $self->{_is_active}; } sub is_confirm { my $self = shift; return $self->{_is_confirm}; } sub queue { my $self = shift; return $self->{_queue}; } sub open { my $self = shift; my %args = @_; if ($self->{_state} != _ST_CLOSED) { $args{on_failure}->('Channel has already been opened'); return $self; } $self->{_state} = _ST_OPENING; $self->{connection}->_push_write_and_read( 'Channel::Open', {}, 'Channel::OpenOk', sub { $self->{_state} = _ST_OPEN; $self->{_is_active} = 1; $args{on_success}->($self); }, sub { $self->{_state} = _ST_CLOSED; $args{on_failure}->($self); }, $self->{id}, ); return $self; } sub close { my $self = shift; my $connection = $self->{connection} or return; my %args = $connection->_set_cbs(@_); # If open in in progess, wait for it; 1s arbitrary timing. weaken(my $wself = $self); my $t; $t = AE::timer 0, 1, sub { (my $self = $wself) or undef $t, return; return if $self->{_state} == _ST_OPENING; # No more tests are required undef $t; # Double close is OK if ($self->{_state} == _ST_CLOSED) { $args{on_success}->($self); return; } $connection->_push_write( $self->_close_frame, $self->{id}, ); # The spec says that after a party sends Channel::Close, it MUST # discard all frames for that channel. So this channel is dead # immediately. $self->_closed(); $connection->_push_read_and_valid( 'Channel::CloseOk', sub { $args{on_success}->($self); $self->_orphan(); }, sub { $args{on_failure}->(@_); $self->_orphan(); }, $self->{id}, ); }; return $self; } sub _closed { my $self = shift; my ($frame,) = @_; $frame ||= $self->_close_frame(); return if $self->{_state} == _ST_CLOSED; $self->{_state} = _ST_CLOSED; # Perform callbacks for all outstanding commands $self->{_queue}->_flush($frame); $self->{_content_queue}->_flush($frame); # Fake nacks of all outstanding publishes $_->($frame) for grep { defined } map { $_->[1] } values %{ $self->{_publish_cbs} }; # Report cancelation of all outstanding consumes my @tags = keys %{ $self->{_consumer_cbs} }; $self->_canceled($_, $frame) for @tags; # Report close to on_close callback { local $@; eval { $self->{on_close}->($frame) }; warn "Error in channel on_close callback, ignored:\n $@ " if $@; } # Reset state (partly redundant) $self->_reset; return $self; } sub _close_frame { my $self = shift; my ($text,) = @_; Net::AMQP::Frame::Method->new( method_frame => Net::AMQP::Protocol::Channel::Close->new( reply_text => $text, ), ); } sub _orphan { my $self = shift; if (my $connection = $self->{connection}) { $connection->_delete_channel($self); } return $self; } sub declare_exchange { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Exchange::Declare', { type => 'direct', passive => 0, durable => 0, auto_delete => 0, internal => 0, %args, # exchange ticket => 0, nowait => 0, # FIXME }, 'Exchange::DeclareOk', $cb, $failure_cb, $self->{id}, ); return $self; } sub bind_exchange { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Exchange::Bind', { %args, # source, destination, routing_key ticket => 0, nowait => 0, # FIXME }, 'Exchange::BindOk', $cb, $failure_cb, $self->{id}, ); return $self; } sub unbind_exchange { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Exchange::Unbind', { %args, # source, destination, routing_key ticket => 0, nowait => 0, # FIXME }, 'Exchange::UnbindOk', $cb, $failure_cb, $self->{id}, ); return $self; } sub delete_exchange { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Exchange::Delete', { if_unused => 0, %args, # exchange ticket => 0, nowait => 0, # FIXME }, 'Exchange::DeleteOk', $cb, $failure_cb, $self->{id}, ); return $self; } sub declare_queue { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Queue::Declare', { queue => '', passive => 0, durable => 0, exclusive => 0, auto_delete => 0, no_ack => 1, %args, ticket => 0, nowait => 0, # FIXME }, 'Queue::DeclareOk', $cb, $failure_cb, $self->{id}, ); } sub bind_queue { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Queue::Bind', { %args, # queue, exchange, routing_key ticket => 0, nowait => 0, # FIXME }, 'Queue::BindOk', $cb, $failure_cb, $self->{id}, ); return $self; } sub unbind_queue { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Queue::Unbind', { %args, # queue, exchange, routing_key ticket => 0, }, 'Queue::UnbindOk', $cb, $failure_cb, $self->{id}, ); return $self; } sub purge_queue { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Queue::Purge', { %args, # queue ticket => 0, nowait => 0, # FIXME }, 'Queue::PurgeOk', $cb, $failure_cb, $self->{id}, ); return $self; } sub delete_queue { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Queue::Delete', { if_unused => 0, if_empty => 0, %args, # queue ticket => 0, nowait => 0, # FIXME }, 'Queue::DeleteOk', $cb, $failure_cb, $self->{id}, ); return $self; } sub publish { my $self = shift; my %args = @_; # Docs should advise channel-level callback over this, but still, better to give user an out unless ($self->{_is_active}) { if (defined $args{on_inactive}) { $args{on_inactive}->(); return $self; } croak "Can't publish on inactive channel (server flow control); provide on_inactive callback"; } my $header_args = delete $args{header}; my $body = delete $args{body}; my $ack_cb = delete $args{on_ack}; my $nack_cb = delete $args{on_nack}; my $return_cb = delete $args{on_return}; defined($header_args) or $header_args = {}; defined($body) or $body = ''; defined($ack_cb) or defined($nack_cb) or defined($return_cb) and !$self->{_is_confirm} and croak "Can't set on_ack/on_nack/on_return callback when not in confirm mode"; my $tag; if ($self->{_is_confirm}) { # yeah, delivery tags in acks are sequential. see Java client $tag = ++$self->{_publish_tag}; if ($return_cb) { $header_args = { %$header_args }; $header_args->{headers}->{_ar_return} = $tag; # just reuse the same value, why not } $self->{_publish_cbs}->{$tag} = [$ack_cb, $nack_cb, $return_cb]; } $self->_publish( %args, )->_header( $header_args, $body, )->_body( $body, ); return $self; } sub _publish { my $self = shift; my %args = @_; $self->{connection}->_push_write( Net::AMQP::Protocol::Basic::Publish->new( exchange => '', mandatory => 0, immediate => 0, %args, # routing_key ticket => 0, ), $self->{id}, ); return $self; } sub _header { my ($self, $args, $body) = @_; my $weight = delete $args->{weight} || 0; # user-provided message headers must be strings. protect values that look like numbers. my $headers = $args->{headers} || {}; my @prot = grep { my $v = $headers->{$_}; !ref($v) && looks_like_number($v) } keys %$headers; if (@prot) { $headers = { %$headers, map { $_ => Net::AMQP::Value::String->new($headers->{$_}) } @prot }; } $self->{connection}->_push_write( Net::AMQP::Frame::Header->new( weight => $weight, body_size => length($body), header_frame => Net::AMQP::Protocol::Basic::ContentHeader->new( content_type => 'application/octet-stream', content_encoding => undef, delivery_mode => 1, priority => 1, correlation_id => undef, expiration => undef, message_id => undef, timestamp => time, type => undef, user_id => $self->{connection}->login_user, app_id => undef, cluster_id => undef, %$args, headers => $headers, ), ), $self->{id}, ); return $self; } sub _body { my ($self, $body,) = @_; my $body_max = $self->{connection}->{_body_max} || length $body; # chunk up body into segments measured by $frame_max while (length $body) { $self->{connection}->_push_write( Net::AMQP::Frame::Body->new( payload => substr($body, 0, $body_max, '')), $self->{id} ); } return $self; } sub consume { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); my $consumer_cb = delete $args{on_consume} || sub {}; my $cancel_cb = delete $args{on_cancel} || sub {}; my $no_ack = delete $args{no_ack} // 1; $self->{connection}->_push_write_and_read( 'Basic::Consume', { consumer_tag => '', no_local => 0, no_ack => $no_ack, exclusive => 0, %args, # queue ticket => 0, nowait => 0, # FIXME }, 'Basic::ConsumeOk', sub { my $frame = shift; my $tag = $frame->method_frame->consumer_tag; $self->{_consumer_cbs}->{$tag} = [ $consumer_cb, $cancel_cb ]; $cb->($frame); }, $failure_cb, $self->{id}, ); return $self; } sub cancel { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); if (!defined $args{consumer_tag}) { $failure_cb->('consumer_tag is not set'); return $self; } my $cons_cbs = $self->{_consumer_cbs}->{$args{consumer_tag}}; unless ($cons_cbs) { $failure_cb->('Unknown consumer_tag'); return $self; } push @$cons_cbs, $cb; $self->{connection}->_push_write( Net::AMQP::Protocol::Basic::Cancel->new( %args, # consumer_tag nowait => 0, ), $self->{id}, ); return $self; } sub _canceled { my $self = shift; my ($tag, $frame,) = @_; my $cons_cbs = delete $self->{_consumer_cbs}->{$tag} or return 0; shift @$cons_cbs; # no more deliveries for my $cb (reverse @$cons_cbs) { $cb->($frame); } return 1; } sub get { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Basic::Get', { no_ack => 1, %args, # queue ticket => 0, }, [qw(Basic::GetOk Basic::GetEmpty)], sub { my $frame = shift; return $cb->({empty => $frame}) if $frame->method_frame->isa('Net::AMQP::Protocol::Basic::GetEmpty'); $self->_push_read_header_and_body('ok', $frame, $cb, $failure_cb); }, $failure_cb, $self->{id}, ); return $self; } sub ack { my $self = shift; my %args = @_; return $self if !$self->_check_open(sub {}); $self->{connection}->_push_write( Net::AMQP::Protocol::Basic::Ack->new( delivery_tag => 0, multiple => ( defined $args{delivery_tag} && $args{delivery_tag} != 0 ? 0 : 1 ), %args, ), $self->{id}, ); return $self; } sub qos { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Basic::Qos', { prefetch_count => 1, %args, prefetch_size => 0, global => 0, }, 'Basic::QosOk', $cb, $failure_cb, $self->{id}, ); return $self; } sub confirm { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); return $self if !$self->_check_version(0, 9, $failure_cb); weaken(my $wself = $self); $self->{connection}->_push_write_and_read( 'Confirm::Select', { %args, nowait => 0, # FIXME }, 'Confirm::SelectOk', sub { my $me = $wself or return; $me->{_is_confirm} = 1; $cb->(); }, $failure_cb, $self->{id}, ); return $self; } sub recover { my $self = shift; my ($cb, $failure_cb, %args) = $self->_delete_cbs(@_); return $self if !$self->_check_open(sub {}); $self->{connection}->_push_write( Net::AMQP::Protocol::Basic::Recover->new( requeue => 1, %args, ), $self->{id}, ); if (!$args{nowait} && $self->_check_version(0, 9)) { $self->{connection}->_push_read_and_valid( 'Basic::RecoverOk', $cb, $failure_cb, $self->{id}, ); } else { $cb->(); } return $self; } sub reject { my $self = shift; my %args = @_; return $self if !$self->_check_open( sub { } ); $self->{connection}->_push_write( Net::AMQP::Protocol::Basic::Reject->new( delivery_tag => 0, requeue => 0, %args, ), $self->{id}, ); return $self; } sub select_tx { my $self = shift; my ($cb, $failure_cb,) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Tx::Select', {}, 'Tx::SelectOk', $cb, $failure_cb, $self->{id}, ); return $self; } sub commit_tx { my $self = shift; my ($cb, $failure_cb,) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Tx::Commit', {}, 'Tx::CommitOk', $cb, $failure_cb, $self->{id}, ); return $self; } sub rollback_tx { my $self = shift; my ($cb, $failure_cb,) = $self->_delete_cbs(@_); return $self if !$self->_check_open($failure_cb); $self->{connection}->_push_write_and_read( 'Tx::Rollback', {}, 'Tx::RollbackOk', $cb, $failure_cb, $self->{id}, ); return $self; } sub push_queue_or_consume { my $self = shift; my ($frame, $failure_cb,) = @_; # Note: the spec says that after a party sends Channel::Close, it MUST # discard all frames for that channel other than Close and CloseOk. if ($frame->isa('Net::AMQP::Frame::Method')) { my $method_frame = $frame->method_frame; if ($method_frame->isa('Net::AMQP::Protocol::Channel::Close')) { $self->{connection}->_push_write( Net::AMQP::Protocol::Channel::CloseOk->new(), $self->{id}, ); $self->_closed($frame); $self->_orphan(); return $self; } elsif ($self->{_state} != _ST_OPEN) { if ($method_frame->isa('Net::AMQP::Protocol::Channel::OpenOk') || $method_frame->isa('Net::AMQP::Protocol::Channel::CloseOk')) { $self->{_queue}->push($frame); } return $self; } elsif ($method_frame->isa('Net::AMQP::Protocol::Basic::Deliver')) { my $cons_cbs = $self->{_consumer_cbs}->{$method_frame->consumer_tag}; my $cb = ($cons_cbs && $cons_cbs->[0]) || sub {}; $self->_push_read_header_and_body('deliver', $frame, $cb, $failure_cb); return $self; } elsif ($method_frame->isa('Net::AMQP::Protocol::Basic::CancelOk') || $method_frame->isa('Net::AMQP::Protocol::Basic::Cancel')) { # CancelOk means we asked for a cancel. # Cancel means queue was deleted; it is not AMQP, but RMQ supports it. if (!$self->_canceled($method_frame->consumer_tag, $frame) && $method_frame->isa('Net::AMQP::Protocol::Basic::CancelOk')) { $failure_cb->("Received CancelOk for unknown consumer tag " . $method_frame->consumer_tag); } return $self; } elsif ($method_frame->isa('Net::AMQP::Protocol::Basic::Return')) { weaken(my $wself = $self); my $cb = sub { my $ret = shift; my $me = $wself or return; my $headers = $ret->{header}->headers || {}; my $onret_cb; if (defined(my $tag = $headers->{_ar_return})) { my $cbs = $me->{_publish_cbs}->{$tag}; $onret_cb = $cbs->[2] if $cbs; } $onret_cb ||= $me->{on_return} || $me->{connection}->{on_return} || sub {}; # oh well $onret_cb->($frame); }; $self->_push_read_header_and_body('return', $frame, $cb, $failure_cb); return $self; } elsif ($method_frame->isa('Net::AMQP::Protocol::Basic::Ack') || $method_frame->isa('Net::AMQP::Protocol::Basic::Nack')) { (my $resp = ref($method_frame)) =~ s/.*:://; my $cbs; if (!$self->{_is_confirm}) { $failure_cb->("Received $resp when not in confirm mode"); } else { my @tags; if ($method_frame->{multiple}) { @tags = sort { $a <=> $b } grep { $_ <= $method_frame->{delivery_tag} } keys %{$self->{_publish_cbs}}; } else { @tags = ($method_frame->{delivery_tag}); } my $cbi = ($resp eq 'Ack') ? 0 : 1; for my $tag (@tags) { my $cbs; if (not $cbs = delete $self->{_publish_cbs}->{$tag}) { $failure_cb->("Received $resp of unknown delivery tag $tag"); } elsif ($cbs->[$cbi]) { $cbs->[$cbi]->($frame); } } } return $self; } elsif ($method_frame->isa('Net::AMQP::Protocol::Channel::Flow')) { $self->{_is_active} = $method_frame->active; $self->{connection}->_push_write( Net::AMQP::Protocol::Channel::FlowOk->new( active => $method_frame->active, ), $self->{id}, ); my $cbname = $self->{_is_active} ? 'on_active' : 'on_inactive'; my $cb = $self->{$cbname} || $self->{connection}->{$cbname} || sub {}; $cb->($frame); return $self; } $self->{_queue}->push($frame); } else { $self->{_content_queue}->push($frame); } return $self; } sub _push_read_header_and_body { my $self = shift; my ($type, $frame, $cb, $failure_cb,) = @_; my $response = {$type => $frame}; my $body_size = 0; $self->{_content_queue}->get(sub{ my $frame = shift; return $failure_cb->('Received data is not header frame') if !$frame->isa('Net::AMQP::Frame::Header'); my $header_frame = $frame->header_frame; return $failure_cb->( 'Header is not Protocol::Basic::ContentHeader' . 'Header was ' . ref $header_frame ) if !$header_frame->isa('Net::AMQP::Protocol::Basic::ContentHeader'); $response->{header} = $header_frame; $body_size = $frame->body_size; }); weaken(my $wcontq = $self->{_content_queue}); my $body_payload = ""; my $w_next_frame; my $next_frame = sub { my $frame = shift; my $contq = $wcontq or return; return $failure_cb->('Received data is not body frame') if !$frame->isa('Net::AMQP::Frame::Body'); $body_payload .= $frame->payload; if (length($body_payload) < $body_size) { # More to come $contq->get($w_next_frame); } else { $frame->payload($body_payload); $response->{body} = $frame; $cb->($response); } }; $w_next_frame = $next_frame; weaken($w_next_frame); $self->{_content_queue}->get($next_frame); return $self; } sub _delete_cbs { my $self = shift; my %args = @_; my $cb = delete $args{on_success} || sub {}; my $failure_cb = delete $args{on_failure} || sub {die @_}; return $cb, $failure_cb, %args; } sub _check_open { my $self = shift; my ($failure_cb) = @_; return 1 if $self->is_open(); $failure_cb->('Channel has already been closed'); return 0; } sub _check_version { my $self = shift; my ($major, $minor, $failure_cb) = @_; my $amaj = $Net::AMQP::Protocol::VERSION_MAJOR; my $amin = $Net::AMQP::Protocol::VERSION_MINOR; return 1 if $amaj >= $major || $amaj == $major && $amin >= $minor; $failure_cb->("Not supported in AMQP $amaj-$amin") if $failure_cb; return 0; } sub DESTROY { my $self = shift; $self->close() if !in_global_destruction && $self->is_open(); return; } 1; __END__ =head1 NAME AnyEvent::RabbitMQ::Channel - Abstraction of an AMQP channel. =head1 SYNOPSIS my $ch = $rf->open_channel(); $ch->declare_exchange(exchange => 'test_exchange'); =head1 DESCRIPTION A RabbitMQ channel. A channel is a light-weight virtual connection within a TCP connection to a RabbitMQ broker. =head1 ARGUMENTS FOR C =over =item on_close Callback invoked when the channel closes. Callback will be passed the incoming message that caused the close, if any. =item on_return Callback invoked when a mandatory or immediate message publish fails. Callback will be passed the incoming message, with accessors C, C, and C. =back =head1 METHODS =head2 declare_exchange (%args) Declare an exchange (to publish messages to) on the server. Arguments: =over =item on_success =item on_failure =item type Default 'direct' =item passive Default 0 =item durable Default 0 =item auto_delete Default 0 =item internal Default 0 =item exchange The name of the exchange =back =head2 bind_exchange Binds an exchange to another exchange, with a routing key. Arguments: =over =item source The name of the source exchange to bind =item destination The name of the destination exchange to bind =item routing_key The routing key to bind with =back =head2 unbind_exchange =head2 delete_exchange =head2 declare_queue Declare a queue, that is, create it if it doesn't exist yet. Arguments: =over =item queue Name of the queue to be declared. If the queue name is the empty string, RabbitMQ will create a unique name for the queue. This is useful for temporary/private reply queues. =item on_success Callback that is called when the queue was declared successfully. The argument to the callback is of type L. To get the name of the Queue (if you declared it with an empty name), you can say on_success => sub { my $method = shift; my $name = $method->method_frame->queue; }; =item on_failure Callback that is called when the declaration of the queue has failed. =item auto_delete 0 or 1, default 0 =item passive 0 or 1, default 0 =item durable 0 or 1, default 0 =item exclusive 0 or 1, default 0 =item no_ack 0 or 1, default 1 =item ticket default 0 =back =head2 bind_queue Binds a queue to an exchange, with a routing key. Arguments: =over =item queue The name of the queue to bind =item exchange The name of the exchange to bind =item routing_key The routing key to bind with =back =head2 unbind_queue =head2 purge_queue Flushes the contents of a queue. =head2 delete_queue Deletes a queue. The queue may not have any active consumers. =head2 publish Publish a message to an exchange Arguments: =over =item body The text body of the message to send. =item header Customer headers for the message (if any). =item exchange The name of the exchange to send the message to. =item routing_key The routing key with which to publish the message. =item on_ack Callback (if any) for confirming acknowledgment when in confirm mode. =back =head2 consume Subscribe to consume messages from a queue. Arguments: =over =item queue The name of the queue to be consumed from. =item on_consume Callback called with an argument of the message which has been consumed. The message is a hash reference, where the value to key C
is an object of type L, L is a L, and C a L. =item on_cancel Callback called if consumption is canceled. This may be at client request or as a side effect of queue deletion. (Notification of queue deletion is a RabbitMQ extension.) =item consumer_tag Identifies this consumer, will be auto-generated if you do not provide it, but you must supply a value if you want to be able to later cancel the subscription. =item on_success Callback called if the subscription was successful (before the first message is consumed). =item on_failure Callback called if the subscription fails for any reason. =item no_ack Pass through the C flag. Defaults to C<1>. If set to C<1>, the server will not expect messages to be acknowledged. =back =head2 publish Publish a message to an exchange. Arguments: =over =item header Hash of AMQP message header info, including the confusingly similar element "headers", which may contain arbitrary string key/value pairs. =item body Message body. =item mandatory Boolean; if true, then if the message doesn't land in a queue (e.g. the exchange has no bindings), it will be "returned." (see "on_return") =item immediate Boolean; if true, then if the message cannot be delivered directly to a consumer, it will be "returned." (see "on_return") =item on_ack Callback called with the frame that acknowledges receipt (if channel is in confirm mode), typically L. =item on_nack Callback called with the frame that declines receipt (if the channel is in confirm mode), typically L or L. =item on_return In AMQP, a "returned" message is one that cannot be delivered in compliance with the C or C flags. If in confirm mode, this callback will be called with the frame that reports message return, typically L. If confirm mode is off or this callback is not provided, then the channel or connection objects' on_return callbacks (if any), will be called instead. NOTE: If confirm mode is on, the on_ack or on_nack callback will be called whether or not on_return is called first. =back =head2 cancel Cancel a queue subscription. Note that the cancellation B take place at once, and further messages may be consumed before the subscription is cancelled. No further messages will be consumed after the on_success callback has been called. Arguments: =over =item consumer_tag Identifies this consumer, needs to be the value supplied when the queue is initially consumed from. =item on_success Callback called if the subscription was successfully cancelled. =item on_failure Callback called if the subscription could not be cancelled for any reason. =back =head2 get Try to get a single message from a queue. Arguments: =over =item queue Mandatory. Name of the queue to try to receive a message from. =item on_success Will be called either with either a message, or, if the queue is empty, a notification that there was nothing to collect from the queue. =item on_failure This callback will be called if an error is signalled on this channel. =back =head2 ack =head2 qos =head2 confirm Put channel into confirm mode. In confirm mode, publishes are confirmed by the server, so the on_ack callback of publish works. =head2 recover =head2 select_tx =head2 commit_tx =head2 rollback_tx =head1 AUTHOR, COPYRIGHT AND LICENSE See L for author(s), copyright and license. =cut AnyEvent-RabbitMQ-1.19/Changes0000644000175000017500000001300312503320630015066 0ustar daveldavelRevision history for Perl extension AnyEvent::RabbitMQ 1.19 Sat Mar 21 16:49:24 GMT 2015 - Add 'no_ack' as an optional argument to the ->consume method (Dave Mueller). - Fill in some missing documentation (Moritz Lenz). 1.18 Mon Sep 29 19:36:00 PDT 2014 - Added the bind_exchange and unbind_exchange methods for exchange-exchange bindings. 1.17 Fri Jul 25 14:02:00 PDT 2014 - Add support for chunking large bodies into multiple AMQP frames, allowing the sending of large messages. 1.16 Sat Apr 12 14:42:00 BST 2014 - Doc fixes (Mark Ellis) - Fix leak when calling ->close + tests (Peter Haworth) 1.15 Mon Jul 1 12:35:00 BST 2013 - Fix paper-bag bug in connection close - calling nonexistent method. 1.14 Fri Jun 7 08:54:00 BST 2013 - Fix paper-bag bug in heartbeat - always lost heartbeat even on active connections - on channel close, automatically call on_return callbacks for any publishes that are waiting - maintain more state around opening and closing to avoid hang/race when server sends Close after client does (this is possible!) - cope with AMQP quirk that in confirm mode, returned messages are *also* acked/nacked - document $channel->publish 1.13 Thu May 2 16:48:58 PDT 2013 - Require Net::AMQP 0.06 to: + Get consume cancel notifications (e.g. queue deletion) + Properly encode user-provided header strings that look like numbers - Fix race between server-sent and client-sent cancellation. - Expect server to send heartbeats as promised. If it doesn't, go President Madagasgar on its ass and SHUT DOWN EVERYTHING. - Rearrange many things and weaken many references to eliminate bad circular references. Some circular refs are actually good, though; leave those. - Allow customized client_properties on connection. - Make test output clearer. 1.12 Thu Apr 11 20:45:00 2013 - Allow AMQP client to adjust tuning, e.g. heartbeat (Chip Salzenberg) - Fix RT#84222, continue reading AMQP packets after a heartbeat. - Spontaneously emit hearts as per amqp 0.9.1 spec. The AMQP spec says, "The client should start sending heartbeats after receiving a Connection.Tune method, and start monitoring heartbeats after receiving Connection.Open." There is no mention of merely responding to heartbeat packets emitted by the server. (Dave Lambley) 1.11 Tue Mar 5 22:22:00 2013 - Fix on_success callback for the Channel->close method (davel). 1.10 Mon Feb 25 13:48:00 2013 - Clarify relationship to Net::RabbitFoot. RT#71099 - Add TLS connection support. RT#81729 1.09 Mon Feb 25 12:03:00 2013 - Support AMQP heartbeat. - Support AMQP 0.9 standard. (Chip Salzenberg) - Stop defining a _return_cb value when not using the mandatory or immediate flags when publishing a message. This means that if you're not using these flags, but are using an infinite set of routing keys, then you won't leak infinite RAM. Currently if you do use these flags and infinitely variable routing keys, we still have a problem as we leak callbacks. RT#79511 1.08 Mon Aug 27 08:43:00 2012 - Improve Data::Dumper options for protocol dumps (Chip Salzenberg) - More thoroughly eliminate memory leaks on incoming messages (Chip Salzenberg) - Properly handle channel close: Ensure pending requests fail immediately (Chip Salzenberg) 1.07 Tue Aug 21 15:47:00 2012 - Fix dist by putting missing version numbers back into all the modules. 1.06 Tue Aug 21 15:10:00 2012 - Fix a race condition stopping connections from closing properly. If you ask to open a channel, and then immediately try to close the connection then the not yet open channel would never remove itself from the associated connection, resulting in the connection never being terminated (as there were still channels associated with it). - Stop leaking all RabbitMQ messages recieved back inside a closure. - Allow multiple clients to have independent connections to RabbitMQ, as long as they all use the same spec file. 1.05 Tue Jul 22 16:55:55 2011 - Fixed a compiling error. 1.04 Tue Jul 19 17:04:24 2011 - Bug fix for consuming large messages. 1.03 Thu Apr 7 02:55:12 2011 - Separate AnyEvent::RabbitMQ from Net::RabbitFoot. - Avoid (additional) issues when in global destruction. - Do not set reply_to to an empty string in the header frame. - Implement basic.reject (requires RabbitMQ >= 2.0.0). - Store server properties in the object for easy server product and sever version access. - Shutdown the AnyEvent handle using push_shutdown. - Be more careful in DESTROY blocks. 1.02 Wed Jun 30 11:35:32 2010 - Fix errors in global destruction due to destruction order being random. - Fix bug if you call ->close on a Net::RabbitFoot instance which is not already connected. Previously this would never return. 1.01 Sun Mar 18 07:21:58 2010 - fix bugs. - support channel.flow. 1.00 Fri Mar 5 11:30:00 2010 - fix module name. 0.01 Sun Dec 6 20:54:03 2009 - original version AnyEvent-RabbitMQ-1.19/t/0000755000175000017500000000000012503322231014040 5ustar daveldavelAnyEvent-RabbitMQ-1.19/t/00_compile.t0000644000175000017500000000025212124544652016167 0ustar daveldaveluse strict; use Test::More tests => 3; BEGIN { use_ok 'AnyEvent::RabbitMQ'; use_ok 'AnyEvent::RabbitMQ::Channel'; use_ok 'AnyEvent::RabbitMQ::LocalQueue'; } AnyEvent-RabbitMQ-1.19/t/01_localqueue.t0000644000175000017500000000107012124544652016676 0ustar daveldaveluse Test::More tests => 10; use AnyEvent::RabbitMQ::LocalQueue; my $q = AnyEvent::RabbitMQ::LocalQueue->new; $q->push(1); $q->get(sub {is $_[0], 1, 'push -> get';}); $q->get(sub {is $_[0], 2, 'get -> push';}); $q->push(2); $q->push(3, 4); $q->push(5, 6); $q->get( sub {is $_[0], 3, '';}, sub {is $_[0], 4, '';}, ); $q->get( sub {is $_[0], 5, '';}, sub {is $_[0], 6, '';}, ); $q->get( sub {is $_[0], 7, '';}, sub {is $_[0], 8, '';}, ); $q->get( sub {is $_[0], 9, '';}, sub {is $_[0], 10, '';}, ); $q->push(7, 8); $q->push(9, 10); AnyEvent-RabbitMQ-1.19/share/0000755000175000017500000000000012503322231014677 5ustar daveldavelAnyEvent-RabbitMQ-1.19/share/README0000644000175000017500000000021612124544652015572 0ustar daveldavelAMQP spec files fixed_amqp0-8.xml - standard 0.8 spec plus Rabbit extensions fixed_amqp0-9-1.xml - standard 0.9.1 spec plus Rabbit extensions AnyEvent-RabbitMQ-1.19/inc/0000755000175000017500000000000012503322231014346 5ustar daveldavelAnyEvent-RabbitMQ-1.19/inc/Module/0000755000175000017500000000000012503322231015573 5ustar daveldavelAnyEvent-RabbitMQ-1.19/inc/Module/Install.pm0000644000175000017500000003013512503322215017543 0ustar daveldavel#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. AnyEvent-RabbitMQ-1.19/inc/Module/Install/0000755000175000017500000000000012503322231017201 5ustar daveldavelAnyEvent-RabbitMQ-1.19/inc/Module/Install/Fetch.pm0000644000175000017500000000462712503322216020604 0ustar daveldavel#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; AnyEvent-RabbitMQ-1.19/inc/Module/Install/Base.pm0000644000175000017500000000214712503322216020420 0ustar daveldavel#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 AnyEvent-RabbitMQ-1.19/inc/Module/Install/Metadata.pm0000644000175000017500000004327712503322216021277 0ustar daveldavel#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; AnyEvent-RabbitMQ-1.19/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612503322216021275 0ustar daveldavel#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; AnyEvent-RabbitMQ-1.19/inc/Module/Install/Makefile.pm0000644000175000017500000002743712503322216021274 0ustar daveldavel#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 AnyEvent-RabbitMQ-1.19/inc/Module/Install/AuthorTests.pm0000644000175000017500000000221512503322216022027 0ustar daveldavel#line 1 package Module::Install::AuthorTests; use 5.005; use strict; use Module::Install::Base; use Carp (); #line 16 use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.002'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } #line 42 sub author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 0); } #line 56 sub recursive_author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 1); } sub _wanted { my $href = shift; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _add_author_tests { my ($self, $dirs, $recurse) = @_; return unless $Module::Install::AUTHOR; my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t'; # XXX: pick a default, later -- rjbs, 2008-02-24 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests"; @dirs = grep { -d } @dirs; if ($recurse) { require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), @dirs); $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir ); } else { $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs ); } } #line 107 1; AnyEvent-RabbitMQ-1.19/inc/Module/Install/Can.pm0000644000175000017500000000615712503322216020254 0ustar daveldavel#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 AnyEvent-RabbitMQ-1.19/inc/Module/Install/Share.pm0000644000175000017500000000464312503322216020613 0ustar daveldavel#line 1 package Module::Install::Share; use strict; use Module::Install::Base (); use File::Find (); use ExtUtils::Manifest (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub install_share { my $self = shift; my $dir = @_ ? pop : 'share'; my $type = @_ ? shift : 'dist'; unless ( defined $type and $type eq 'module' or $type eq 'dist' ) { die "Illegal or invalid share dir type '$type'"; } unless ( defined $dir and -d $dir ) { require Carp; Carp::croak("Illegal or missing directory install_share param: '$dir'"); } # Split by type my $S = ($^O eq 'MSWin32') ? "\\" : "\/"; my $root; if ( $type eq 'dist' ) { die "Too many parameters to install_share" if @_; # Set up the install $root = "\$(INST_LIB)${S}auto${S}share${S}dist${S}\$(DISTNAME)"; } else { my $module = Module::Install::_CLASS($_[0]); unless ( defined $module ) { die "Missing or invalid module name '$_[0]'"; } $module =~ s/::/-/g; $root = "\$(INST_LIB)${S}auto${S}share${S}module${S}$module"; } my $manifest = -r 'MANIFEST' ? ExtUtils::Manifest::maniread() : undef; my $skip_checker = $ExtUtils::Manifest::VERSION >= 1.54 ? ExtUtils::Manifest::maniskip() : ExtUtils::Manifest::_maniskip(); my $postamble = ''; my $perm_dir = eval($ExtUtils::MakeMaker::VERSION) >= 6.52 ? '$(PERM_DIR)' : 755; File::Find::find({ no_chdir => 1, wanted => sub { my $path = File::Spec->abs2rel($_, $dir); if (-d $_) { return if $skip_checker->($File::Find::name); $postamble .=<<"END"; \t\$(NOECHO) \$(MKPATH) "$root${S}$path" \t\$(NOECHO) \$(CHMOD) $perm_dir "$root${S}$path" END } else { return if ref $manifest && !exists $manifest->{$File::Find::name}; return if $skip_checker->($File::Find::name); $postamble .=<<"END"; \t\$(NOECHO) \$(CP) "$dir${S}$path" "$root${S}$path" END } }, }, $dir); # Set up the install $self->postamble(<<"END_MAKEFILE"); config :: $postamble END_MAKEFILE # The above appears to behave incorrectly when used with old versions # of ExtUtils::Install (known-bad on RHEL 3, with 5.8.0) # So when we need to install a share directory, make sure we add a # dependency on a moderately new version of ExtUtils::MakeMaker. $self->build_requires( 'ExtUtils::MakeMaker' => '6.11' ); # 99% of the time we don't want to index a shared dir $self->no_index( directory => $dir ); } 1; __END__ #line 154 AnyEvent-RabbitMQ-1.19/inc/Module/Install/Win32.pm0000644000175000017500000000340312503322216020444 0ustar daveldavel#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; AnyEvent-RabbitMQ-1.19/README0000644000175000017500000000166512124544652014501 0ustar daveldavelThis is Perl module AnyEvent::RabbitMQ. AnyEvent::RabbitMQ is an AMQP(Advanced Message Queuing Protocol) client library, that is intended to allow you to interact with AMQP-compliant message brokers/servers such as RabbitMQ in an asynchronous fashion. You can use AnyEvent::RabbitMQ to - * Declare and delete exchanges * Declare, delete, bind and unbind queues * Set QoS * Publish, consume, get, ack, recover and reject messages * Select, commit and rollback transactions AnyEvent::RabbitMQ is known to work with RabbitMQ versions 2.5.1 and version 0-8 of the AMQP specification. INSTALLATION Download it, unpack it, then build it as per the usual: % perl Makefile.PL % make && make test Then install it: % make install DOCUMENTATION AnyEvent::RabbitMQ documentation is available as in POD. So you can do: % perldoc AnyEvent::RabbitMQ to read the documentation online with your favorite pager. Masahito Ikuta AnyEvent-RabbitMQ-1.19/META.yml0000644000175000017500000000150312503322217015051 0ustar daveldavel--- abstract: 'An asynchronous and multi channel Perl AMQP client.' author: - 'Masahito Ikuta ' build_requires: ExtUtils::MakeMaker: 6.59 Test::Exception: 0 Test::More: 0 version: 0 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: AnyEvent-RabbitMQ no_index: directory: - inc - share - t - xt requires: AnyEvent: 0 Devel::GlobalDestruction: 0 File::ShareDir: 0 List::MoreUtils: 0 Net::AMQP: 0.06 Readonly: 1.03 namespace::clean: 0 perl: 5.10.0 resources: license: http://dev.perl.org/licenses/ repository: git://github.com/bobtfish/AnyEvent-RabbitMQ.git version: 1.19 AnyEvent-RabbitMQ-1.19/Makefile.PL0000644000175000017500000000105112503322063015547 0ustar daveldaveluse inc::Module::Install; name 'AnyEvent-RabbitMQ'; all_from 'lib/AnyEvent/RabbitMQ.pm'; requires 'List::MoreUtils'; requires 'Net::AMQP' => '0.06'; requires 'AnyEvent'; requires 'Devel::GlobalDestruction'; requires 'namespace::clean'; requires 'File::ShareDir'; requires 'Readonly' => '1.03'; tests 't/*.t'; author_tests 'xt'; install_share; perl_version '5.10'; build_requires 'Test::More'; build_requires 'Test::Exception'; build_requires 'version'; resources( repository => 'git://github.com/bobtfish/AnyEvent-RabbitMQ.git', ); WriteAll;