File Coverage

blib/lib/Test/Mojo/IRC.pm
Criterion Covered Total %
statement 72 73 98.6
branch 18 26 69.2
condition 1 4 25.0
subroutine 12 13 92.3
pod 3 3 100.0
total 106 119 89.0


line stmt bran cond sub pod time code
1             package Test::Mojo::IRC;
2 2     2   2130 use Mojo::Base -base;
  2         431108  
  2         22  
3              
4 2     2   1998 use Mojo::File;
  2         67818  
  2         143  
5 2     2   1383 use Mojo::IOLoop::Server;
  2         287018  
  2         20  
6 2     2   1290 use Mojo::IRC;
  2         7  
  2         24  
7              
8             $ENV{TEST_MOJO_IRC_SERVER_TIMEOUT} ||= $ENV{TEST_MOJO_IRC_SERVER} ? 10 : 4;
9              
10             has server => '';
11              
12             has welcome_message => <<'HERE';
13             :hybrid8.local NOTICE AUTH :*** Looking up your hostname...
14             :hybrid8.local NOTICE AUTH :*** Checking Ident
15             :hybrid8.local NOTICE AUTH :*** Found your hostname
16             :hybrid8.local NOTICE AUTH :*** No Ident response
17             HERE
18              
19             sub on {
20 2     2 1 21 my ($self, $irc, $event, $cb) = @_;
21 2         3 push @{$self->{subscriptions}}, $irc, $event, $irc->on($event => $cb);
  2         9  
22 2         15 $self;
23             }
24              
25             sub run {
26 2     2 1 850 my ($self, $reply_on, $cb) = @_;
27 2     0   23 my $guard = Mojo::IOLoop->timer($ENV{TEST_MOJO_IRC_SERVER_TIMEOUT}, sub { Mojo::IOLoop->stop });
  0         0  
28 2         166 my @subscriptions;
29              
30 2         8 local $self->{from_client} = '';
31 2         7 local $self->{reply_on} = $reply_on;
32 2         6 local $self->{subscriptions} = \@subscriptions;
33              
34 2         9 $self->$cb;
35 2         3425 Mojo::IOLoop->remove($guard);
36              
37 2         134 while (@subscriptions) {
38 2         112 my ($irc, $event, $cb) = splice @subscriptions, 0, 3, ();
39 2         18 $irc->unsubscribe($event => $cb);
40             }
41              
42 2         31 $self;
43             }
44              
45             sub start_server {
46 3     3 1 293 my $self = shift;
47              
48 3 100       23 return $self->new->tap('start_server') unless ref $self;
49 2 50       11 return $self->server if $self->server;
50 2 50       35 return $ENV{TEST_MOJO_IRC_SERVER} if $ENV{TEST_MOJO_IRC_SERVER};
51              
52 2         30 my $port = Mojo::IOLoop::Server->generate_port;
53 2         2419 my $write;
54              
55             $write = sub {
56 212 100   212   3238 return unless length $self->{server_buf};
57 210         1569 return shift->write(substr($self->{server_buf}, 0, int(10 + rand 20), ''), sub { shift->$write });
  208         23605  
58 2         21 };
59              
60             $self->{server_id} = Mojo::IOLoop->server(
61             {address => '127.0.0.1', port => $port},
62             sub {
63 2     2   1209 my ($ioloop, $stream) = @_;
64              
65             $stream->on(
66             read => sub {
67 2         395 my ($stream, $buf) = @_;
68 2         10 $self->{from_client} .= $buf;
69              
70 2         23 while ($buf =~ /[\015\012]/g) {
71 5 50       9 last unless @{$self->{reply_on} || []};
  5 100       26  
72 3 50       50 last unless $self->{from_client} =~ $self->{reply_on}[0];
73 3         23 $self->_concat_server_buf($self->{reply_on}[1]);
74 3         9 splice @{$self->{reply_on}}, 0, 2, ();
  3         20  
75             }
76              
77 2         9 $stream->$write;
78             }
79 2         20 );
80              
81 2         20 $self->_concat_server_buf($self->welcome_message);
82 2         33 $stream->$write;
83             }
84 2         38 );
85              
86 2         2091 $self->{server_buf} = '';
87 2         17 $self->server("127.0.0.1:$port")->server;
88             }
89              
90             sub _concat_server_buf {
91 5     5   52 my ($self, $buf) = @_;
92              
93 5 100       55 if (ref $buf eq 'ARRAY') {
    100          
94 1 50       11 $buf = Mojo::Loader::data_section(@$buf == 1 ? ('main', @$buf) : @$buf);
95             }
96             elsif (ref $buf) {
97 2         15 $buf = Mojo::File::path(split '/', $$buf)->slurp;
98             }
99              
100 5         606 $buf =~ s/[\015\012]/\015\012/g;
101 5         62 $self->{server_buf} .= $buf;
102             }
103              
104             sub import {
105 2     2   22 my $class = shift;
106 2   50     7 my $arg = shift // '';
107 2         6 my $caller = caller;
108              
109 2 50       15 return unless $arg =~ /^(?:-basic|-ua)$/;
110 2         47 $_->import for qw(strict warnings utf8);
111 2         162 feature->import(':5.10');
112 2 50 0     8 eval "require Mojo::IRC::UA;1" or die $@ if $arg eq '-ua';
113 2 50   2   1599 eval "package $caller; use Test::More; 1" or die $@;
  2         136308  
  2         25  
  2         192  
114             }
115              
116             1;
117              
118             =encoding utf8
119              
120             =head1 NAME
121              
122             Test::Mojo::IRC - Module for testing Mojo::IRC
123              
124             =head1 SYNOPSIS
125              
126             use Test::Mojo::IRC -basic;
127              
128             my $t = Test::Mojo::IRC->start_server;
129             my $irc = Mojo::IRC->new(server => $t->server);
130              
131             # simulate server/client communication
132             $t->run(
133             [
134             # Send "welcome.irc" from the DATA section when client sends "NICK"
135             qr{\bNICK\b} => [qw(main motd.irc)],
136             ],
137             sub {
138             my $err;
139             my $motd = 0;
140             $t->on($irc, irc_rpl_motd => sub { $motd++ });
141             $t->on($irc, irc_rpl_endofmotd => sub { Mojo::IOLoop->stop; }); # need to manually stop the IOLoop
142             $irc->connect(sub { $err = $_[1]; });
143             Mojo::IOLoop->start; # need to manually start the IOLoop
144             is $err, "", "connected";
145             is $motd, 3, "message of the day";
146             },
147             );
148              
149             done_testing;
150              
151             __DATA__
152             @@ motd.irc
153             :spectral.shadowcat.co.uk 375 test123 :- spectral.shadowcat.co.uk Message of the Day -
154             :spectral.shadowcat.co.uk 372 test123 :- We scan all connecting clients for open proxies and other
155             :spectral.shadowcat.co.uk 372 test123 :- exploitable nasties. If you don't wish to be scanned,
156             :spectral.shadowcat.co.uk 372 test123 :- don't connect again, and sorry for scanning you this time.
157             :spectral.shadowcat.co.uk 376 test123 :End of /MOTD command.
158              
159             =head1 DESCRIPTION
160              
161             L is a module for making it easier to test L
162             applications.
163              
164             =head1 ENVIRONMENT VARIABLES
165              
166             =head2 TEST_MOJO_IRC_SERVER
167              
168             C can be set to point to a live server. If the variable
169             is set, L will simply return L instead
170             of setting up a server.
171              
172             =head1 ATTRIBUTES
173              
174             =head2 server
175              
176             $str = $self->server;
177              
178             Returns the server address, "host:port", that L set up.
179              
180             =head2 welcome_message
181              
182             $str = $self->welcome_message;
183             $self = $self->welcome_message($str);
184              
185             Holds a message which will be sent to the client on connect.
186              
187             =head1 METHODS
188              
189             =head2 on
190              
191             $self->on($irc, $event, $cb);
192              
193             Will attach events to the L<$irc|Mojo::IRC> object which is removed
194             after L has completed. See L for example code.
195              
196             =head2 run
197              
198             $self->run($reply_on, sub { my $self = shift });
199              
200             Used to simulate communication between IRC server and client. The way this
201             works is that the C<$cb> will initiate L or
202             L to the server and the server will then respond
203             with the data from either L or C<$reply_on> on these
204             events.
205              
206             C<$reply_on> is an array-ref of regex/buffer pairs. Each time a message
207             from the client match the first regex in the C<$reply_on> array the
208             buffer will be sent back to the client and the regex/buffer will be removed.
209             This means that the order of the pairs are important. The buffer can be...
210              
211             =over 4
212              
213             =item * Scalar
214              
215             Plain text.
216              
217             =item * Scalar ref
218              
219             Path to file on disk.
220              
221             =item * Array ref
222              
223             The module name and file passed on to L. The default
224             package is "main", meaning the two examples below is the same:
225              
226             $self->run([qr{JOIN}, ["join-reply.irc"]], sub { my $self = shift });
227             $self->run([qr{JOIN}, ["main", "join-reply.irc"]], sub { my $self = shift });
228              
229             =back
230              
231             Note that starting and stopping the L is up to you, but
232             there is also a master timeout which will stop the IOLoop if running for too
233             long.
234              
235             See L for example.
236              
237             =head2 start_server
238              
239             $server = $self->start_server;
240             $self = Test::Mojo::IRC->start_server;
241              
242             Will start a test server and return L. It can also be called as
243             a class method which will return a new object.
244              
245             =head2 import
246              
247             use Test::Mojo::IRC -basic;
248              
249             Loading this module with "-basic" will import L, L, L,
250             L and 5.10 features into the caller namespace.
251              
252             =head1 COPYRIGHT AND LICENSE
253              
254             Copyright (C) 2014, Jan Henning Thorsen
255              
256             This program is free software, you can redistribute it and/or modify it under
257             the terms of the Artistic License version 2.0.
258              
259             =head1 AUTHOR
260              
261             Jan Henning Thorsen - C
262              
263             =cut