1package Net::XMPP2::TestClient;
2use strict;
3no warnings;
4use AnyEvent;
5use Net::XMPP2::Client;
6use Net::XMPP2::Util qw/stringprep_jid prep_bare_jid dump_twig_xml/;
7use Net::XMPP2::Namespaces qw/xmpp_ns/;
8use Test::More;
9
10=head1 NAME
11
12Net::XMPP2::TestClient - XMPP Test Client for tests
13
14=head1 SYNOPSIS
15
16=head1 DESCRIPTION
17
18This module is a helper module to ease the task of testing.
19If you want to run the developer test suite you have to set the environment
20variable C<NET_XMPP2_TEST> to something like this:
21
22   NET_XMPP2_TEST="test_me@your_xmpp_server.tld:secret_password"
23
24Most tests will try to connect two accounts, so please take a server
25that allows two connections from the same IP.
26
27If you also want to run the MUC tests (see L<Net::XMPP2::Ext::MUC>)
28you also need to setup the environment variable C<NET_XMPP2_TEST_MUC>
29to contain the domain of a MUC service:
30
31   NET_XMPP2_TEST_MUC="conference.your_xmpp_server.tld"
32
33If you see some tests fail and want to know more about the protocol flow
34you can enable the protocol debugging output by setting C<NET_XMPP2_TEST_DEBUG>
35to '1':
36
37   NET_XMPP2_TEST_DEBUG=1
38
39(NOTE: You will only see the output of this by running a single test)
40
41If one of the tests takes longer than the preconfigured 20 seconds default
42timeout in your setup you can set C<NET_XMPP2_TEST_TIMEOUT>:
43
44   NET_XMPP2_TEST_TIMEOUT=60  # for a 1 minute timeout
45
46=head1 CLEANING UP
47
48If the tests went wrong somewhere or you interrupted the tests you might
49want to delete the accounts from the server manually, then run:
50
51   perl t/z_*_unregister.t
52
53=head1 MANUAL TESTING
54
55If you just want to run a single test yourself, just execute the register
56test before doing so:
57
58   perl t/z_00_register.t
59
60And then you could eg. run:
61
62   perl t/z_03_iq_auth.t
63
64=head1 METHODS
65
66=head2 new (%args)
67
68Following arguments can be passed in C<%args>:
69
70=over 4
71
72=back
73
74=cut
75
76sub new_or_exit {
77   my $this = shift;
78   my $class = ref($this) || $this;
79   my $self = {
80      timeout      => 20,
81      finish_count =>  1,
82      @_
83   };
84
85   if ($ENV{NET_XMPP2_TEST_DEBUG}) {
86      $self->{debug} = 1;
87   }
88
89   if ($ENV{NET_XMPP2_TEST_TIMEOUT}) {
90      $self->{timeout} = $ENV{NET_XMPP2_TEST_TIMEOUT};
91   }
92
93   $self->{tests};
94
95   if ($self->{muc_test} && not $ENV{NET_XMPP2_TEST_MUC}) {
96      plan skip_all => "environment var NET_XMPP2_TEST_MUC not set! Set it to a conference!";
97      exit;
98   }
99
100   if ($ENV{NET_XMPP2_TEST}) {
101      plan tests => $self->{tests} + 1
102   } else {
103      plan skip_all => "environment var NET_XMPP2_TEST not set! (see also Net::XMPP2::TestClient)!";
104      exit;
105   }
106
107   bless $self, $class;
108   $self->init;
109   $self
110}
111
112sub init {
113   my ($self) = @_;
114   $self->{condvar} = AnyEvent->condvar;
115   $self->{timeout} =
116      AnyEvent->timer (
117         after => $self->{timeout}, cb => sub {
118            $self->{error} .= "Error: Test Timeout\n";
119            $self->{condvar}->broadcast;
120         }
121      );
122
123   my $cl = $self->{client} = Net::XMPP2::Client->new (debug => $self->{debug} || 0);
124   my ($jid, $password) = split /:/, $ENV{NET_XMPP2_TEST}, 2;
125
126   $self->{jid} = $jid;
127   $self->{password} = $password;
128   $cl->add_account ($jid, $password, undef, undef, $self->{connection_args});
129
130   if ($self->{two_accounts}) {
131      $self->{connected_accounts} = {};
132
133      $cl->reg_cb (session_ready => sub {
134         my ($cl, $acc) = @_;
135         $self->{connected_accounts}->{$acc->bare_jid} = $acc->jid;
136         my (@jids) = values %{$self->{connected_accounts}};
137         my $cnt = scalar @jids;
138         if ($cnt > 1) {
139            $cl->event (two_accounts_ready => $acc, @jids);
140         }
141      });
142
143      $cl->add_account ("2nd_".$jid, $password, undef, undef, $self->{connection_args});
144   }
145
146
147   if ($self->{muc_test} && $ENV{NET_XMPP2_TEST_MUC}) {
148      $self->{muc_room} = "test_nxmpp2@" . $ENV{NET_XMPP2_TEST_MUC};
149
150      my $disco = $self->instance_ext ('Net::XMPP2::Ext::Disco');
151      $self->{disco} = $disco;
152
153      $cl->reg_cb (
154         before_session_ready => sub {
155            my ($cl, $acc) = @_;
156            my $con = $acc->connection;
157            $con->add_extension (
158               $self->{mucs}->{$acc->bare_jid}
159                  = Net::XMPP2::Ext::MUC->new (disco => $disco, connection => $con)
160            );
161         },
162         two_accounts_ready => sub {
163            my ($cl, $acc, $jid1, $jid2) = @_;
164            my $cnt = 0;
165            my ($room1, $room2);
166            my $muc = $self->{muc1} = $self->{mucs}->{prep_bare_jid $jid1};
167
168            $muc->join_room ($self->{muc_room}, "test1", sub {
169               my ($room, $user, $error) = @_;
170               $room1 = $room;
171               if ($error) {
172                  $self->{error} .= "Error: Couldn't join $self->{muc_room} as 'test1': ".$error->string."\n";
173                  $self->{condvar}->broadcast;
174               } else {
175                  my $muc = $self->{muc2} = $self->{mucs}->{prep_bare_jid $jid2};
176                  $muc->join_room ($self->{muc_room}, "test2", sub {
177                     my ($room, $user, $error) = @_;
178                     my $room2 = $room;
179                     if ($error) {
180                        $self->{error} .= "Error: Couldn't join $self->{muc_room} as 'test2'".$error->string."\n";
181                        $self->{condvar}->broadcast;
182                     } else {
183                        $cl->event (two_rooms_joined => $acc, $jid1, $jid2, $room1, $room2)
184                     }
185                  });
186               }
187            });
188
189
190         }
191      );
192   }
193
194
195   $cl->reg_cb (error => sub {
196      my ($cl, $acc, $error) = @_;
197      $self->{error} .= "Error: " . $error->string . "\n";
198      $self->finish unless $self->{continue_on_error};
199   });
200
201   $cl->start;
202}
203
204sub checkpoint {
205   my ($self, $name, $cnt, $cb) = @_;
206   $self->{checkpoints}->{$name} = [$cnt, $cb];
207}
208
209sub reached_checkpoint {
210   my ($self, $name) = @_;
211   my $chp = $self->{checkpoints}->{$name}
212      or die "no such checkpoint defined: $name";
213   $chp->[0]--;
214   if ($chp->[0] <= 0) {
215      $chp->[1]->();
216      delete $self->{checkpoints}->{$name};
217   }
218}
219
220sub main_account { ($_[0]->{jid}, $_[0]->{password}) }
221
222sub client { $_[0]->{client} }
223
224sub tests { $_[0]->{tests} }
225
226sub instance_ext {
227   my ($self, $ext, @args) = @_;
228   eval "require $ext; 1";
229   if ($@) { die "Couldn't load '$ext': $@" }
230   my $eo = $ext->new (@args);
231   $self->{client}->add_extension ($eo);
232   $eo
233}
234
235sub finish {
236   my ($self) = @_;
237   $self->{_cur_finish_cnt}++;
238   if ($self->{finish_count} <= $self->{_cur_finish_cnt}) {
239      $self->{condvar}->broadcast;
240   }
241}
242
243sub wait {
244   my ($self) = @_;
245   $self->{condvar}->wait;
246
247   if ($self->error) {
248      fail ("error free");
249      diag ($self->error);
250   } else {
251      pass ("error free");
252   }
253}
254
255sub error { $_[0]->{error} }
256
257=head1 AUTHOR
258
259Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
260
261=head1 COPYRIGHT & LICENSE
262
263Copyright 2007 Robin Redeker, all rights reserved.
264
265This program is free software; you can redistribute it and/or modify it
266under the same terms as Perl itself.
267
268=cut
269
2701; # End of Net::XMPP2::TestClient
271