Add Perl tutorial files.

Author: Lanzaa

perl/README.md

@@ -0,0 +1,49 @@
+# Perl code for RabbitMQ tutorials
+
+Here you can find Perl code examples from [RabbitMQ
+tutorials](http://www.rabbitmq.com/getstarted.html).
+
+To successfully use the examples you will need a running RabbitMQ server.
+
+## Requirements
+
+To run this code you need to intall Net::RabbitFoot
+
+For tutorial six UUID::Tiny needs to be installed.
+
+## Code
+
+[Tutorial one: "Hello World!"](http://www.rabbitmq.com/tutorial-one-python.html):
+
+    perl send.pl
+    perl receive.pl
+
+
+[Tutorial two: Work Queues](http://www.rabbitmq.com/tutorial-two-python.html):
+
+    perl new_task.pl "A very hard task which takes two seconds.."
+    perl worker.pl
+
+
+[Tutorial three: Publish/Subscribe](http://www.rabbitmq.com/tutorial-three-python.html):
+
+    perl receive_logs.pl
+    perl emit_log.pl "info: This is the log message"
+
+
+[Tutorial four: Routing](http://www.rabbitmq.com/tutorial-four-python.html):
+
+    perl receive_logs_direct.pl info
+    perl emit_log_direct.pl info "The message"
+
+
+[Tutorial five: Topics](http://www.rabbitmq.com/tutorial-five-python.html):
+
+    perl receive_logs_topic.pl "*.rabbit"
+    perl emit_log_topic.pl red.rabbit Hello
+
+
+[Tutorial six: RPC](http://www.rabbitmq.com/tutorial-six-python.html):
+
+    perl rpc_server.pl
+    perl rpc_client.pl

perl/emit_log.pl

@@ -0,0 +1,35 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Net::RabbitFoot;
+
+use Data::Dumper;
+
+my $conn = Net::RabbitFoot->new()->load_xml_spec()->connect(
+    host => 'localhost',
+    port => 5672,
+    user => 'guest',
+    pass => 'guest',
+    vhost => '/',
+);
+
+my $channel = $conn->open_channel();
+
+$channel->declare_exchange(
+    exchange => 'logs',
+    type => 'fanout',
+);
+
+my $msg = join(' ', @ARGV) || "info: Hello World!";
+
+$channel->publish(
+    exchange => 'logs',
+    routing_key => '',
+    body => $msg,
+);
+
+print " [x] Sent $msg\n";
+
+$conn->close();

perl/emit_log_direct.pl

@@ -0,0 +1,34 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Net::RabbitFoot;
+
+my $conn = Net::RabbitFoot->new()->load_xml_spec()->connect(
+    host => 'localhost',
+    port => 5672,
+    user => 'guest',
+    pass => 'guest',
+    vhost => '/',
+);
+
+my $channel = $conn->open_channel();
+
+$channel->declare_exchange(
+    exchange => 'direct_logs',
+    type => 'direct',
+);
+
+my $severity = delete $ARGV[0] || 'info';
+my $msg = join(' ', @ARGV[1..$#ARGV]) || 'Hello World!';
+
+$channel->publish(
+    exchange => 'direct_logs',
+    routing_key => $severity,
+    body => $msg,
+);
+
+print " [x] Send $severity: $msg\n";
+
+$conn->close();

perl/emit_log_topic.pl

@@ -0,0 +1,36 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Net::RabbitFoot;
+use AnyEvent;
+
+my $conn = Net::RabbitFoot->new()->load_xml_spec()->connect(
+    host => 'localhost',
+    port => 5672,
+    user => 'guest',
+    pass => 'guest',
+    vhost => '/',
+);
+
+my $channel = $conn->open_channel();
+
+$channel->declare_exchange(
+    exchange => 'topic_logs',
+    type => 'topic',
+);
+
+my $routing_key = $ARGV[0] || 'anonymous.info';
+my $msg = join(' ', @ARGV[1..$#ARGV]) || 'Hello World!';
+
+$channel->publish(
+    exchange => 'topic_logs',
+    routing_key => $routing_key,
+    body => $msg,
+);
+
+print " [x] Sent $routing_key:$msg\n";
+
+$conn->close();
+

perl/new_task.pl

@@ -0,0 +1,36 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Net::RabbitFoot;
+
+my $conn = Net::RabbitFoot->new()->load_xml_spec()->connect(
+    host => 'localhost',
+    port => 5672,
+    user => 'guest',
+    pass => 'guest',
+    vhost => '/',
+    timeout => 1,
+);
+
+
+my $chan = $conn->open_channel();
+
+$chan->declare_queue(
+    queue => 'task_queue',
+    durable => 1,
+);
+
+my $msg = join(' ', @ARGV) || "Hello World!";
+
+$chan->publish(
+    exchange => '',
+    routing_key => 'task_queue',
+    body => $msg,
+);
+
+print " [x] Sent '$msg'\n";
+
+$conn->close();
+

perl/receive.pl

@@ -0,0 +1,36 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Net::RabbitFoot;
+use AnyEvent;
+
+my $conn = Net::RabbitFoot->new()->load_xml_spec()->connect(
+    host => 'localhost',
+    port => 5672,
+    user => 'guest',
+    pass => 'guest',
+    vhost => '/',
+);
+
+my $ch = $conn->open_channel();
+
+$ch->declare_queue(queue => 'hello');
+
+print " [*] Waiting for messages. To exit press CTRL-C\n";
+
+sub callback {
+    my $var = shift;
+    my $body = $var->{body}->{payload};
+    print " [X] Recevied $body\n";
+}
+
+$ch->consume(
+    on_consume => \&callback,
+    no_ack => 1,
+);
+
+# Wait forever
+AnyEvent->condvar->recv;
+

perl/receive_logs.pl

@@ -0,0 +1,48 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use AnyEvent;
+use Net::RabbitFoot;
+
+my $conn = Net::RabbitFoot->new()->load_xml_spec()->connect(
+    host => 'localhost',
+    port => 5672,
+    user => 'guest',
+    pass => 'guest',
+    vhost => '/',
+);
+
+my $channel = $conn->open_channel();
+
+$channel->declare_exchange(
+    exchange => 'logs',
+    type => 'fanout',
+);
+
+my $result = $channel->declare_queue( exclusive => 1, );
+
+my $queue_name = $result->{method_frame}->{queue};
+
+$channel->bind_queue(
+    exchange => 'logs',
+    queue => $queue_name,
+);
+
+print " [*] Waiting for logs. To exit press CTRL-C\n";
+
+sub callback {
+    my $var = shift;
+    my $body = $var->{body}->{payload};
+
+    print " [x] $body\n";
+}
+
+$channel->consume(
+    on_consume => \&callback,
+    queue => $queue_name,
+    no_ack => 1,
+);
+
+AnyEvent->condvar->recv;

perl/receive_logs_direct.pl

@@ -0,0 +1,54 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use AnyEvent;
+use Net::RabbitFoot;
+
+my $conn = Net::RabbitFoot->new()->load_xml_spec()->connect(
+    host => 'localhost',
+    port => 5672,
+    user => 'guest',
+    pass => 'guest',
+    vhost => '/',
+);
+
+my $channel = $conn->open_channel();
+
+$channel->declare_exchange(
+    exchange => 'direct_logs',
+    type => 'direct',
+);
+
+my $result = $channel->declare_queue(
+    exclusive => 1,
+);
+
+my $queue_name = $result->{method_frame}->{queue};
+
+my @severities = @ARGV or die "Usage: $0 [info] [warning] [error]\n";
+foreach my $severity (@severities) {
+    $channel->bind_queue(
+        exchange => 'direct_logs',
+        queue => $queue_name,
+        routing_key => $severity,
+    );
+}
+
+print " [*] Waiting for logs. To exit press CTRL-C\n";
+
+sub callback {
+    my $var = shift;
+    my $body = $var->{body}->{payload};
+    my $routing_key = $var->{deliver}->{method_frame}->{routing_key};
+    print " [x] $routing_key: $body\n";
+}
+
+$channel->consume(
+    on_consume => \&callback,
+    no_ack => 1,
+);
+
+# Wait forever
+AnyEvent->condvar->recv;

perl/receive_logs_topic.pl

@@ -0,0 +1,54 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Net::RabbitFoot;
+use AnyEvent;
+
+my $conn = Net::RabbitFoot->new()->load_xml_spec()->connect(
+    host => 'localhost',
+    port => 5672,
+    user => 'guest',
+    pass => 'guest',
+    vhost => '/',
+);
+
+my $channel = $conn->open_channel();
+
+$channel->declare_exchange(
+    exchange => 'topic_logs',
+    type => 'topic',
+);
+
+my $result = $channel->declare_queue(exclusive => 1);
+
+my $queue_name = $result->{method_frame}->{queue};
+
+my @binding_keys = @ARGV or die "Usage: $0 [binding_key]...\n";
+
+for my $key (@binding_keys) {
+    $channel->bind_queue(
+        exchange => 'topic_logs',
+        queue => $queue_name,
+        routing_key => $key,
+    );
+}
+
+print " [*] Waiting for logs. To exit press CTRL-C\n";
+
+sub callback {
+    my $var = shift;
+    my $body = $var->{body}->{payload};
+    my $routing_key = $var->{deliver}->{method_frame}->{routing_key};
+    print " [x] $routing_key:$body\n";
+}
+
+$channel->consume(
+    on_consume => \&callback,
+    no_ack => 1,
+);
+
+# Wait forever
+AnyEvent->condvar->recv;
+