Net/XMPP2/Connection.pm

package Net::XMPP2::Connection;
use warnings;
use strict;
use AnyEvent;
use IO::Socket::INET;
use Net::XMPP2::Parser;
use Net::XMPP2::Writer;
use Net::XMPP2::Util;
use Net::XMPP2::Namespaces qw/xmpp_ns/;
use Net::DNS;

our @ISA = qw/Net::XMPP2::SimpleConnection/;

=head1 NAME

Net::XMPP2::Connection - A XML stream that implements the XMPP RFC 3920.

=head1 SYNOPSIS

   use Net::XMPP2::Connection;

   my $con =
      Net::XMPP2::Connection->new (
         username => "abc",
         domain => "jabber.org",
         resource => "Net::XMPP2"
      );

   $con->connect or die "Couldn't connect to jabber.org: $!";
   $con->init;
   $con->reg_cb (stream_ready => sub { print "XMPP stream ready!\n" });

=head1 DESCRIPTION

This module represents a XMPP stream as described in RFC 3920. You can issue the basic
XMPP XML stanzas with methods like C<send_iq>, C<send_message> and C<send_presence>.

And receive events with the C<reg_cb> event framework from the connection.

If you need instant messaging stuff please take a look at C<Net::XMPP2::IM::Connection>.

=head1 METHODS

=head2 new (%args)

Following arguments can be passed in C<%args>:

=over 4

=item language => $tag

This should be the language of the human readable contents that
will be transmitted over the stream. The default will be 'en'.

Please look in RFC 3066 how C<$tag> should look like.

=item resource => $resource

If this argument is given C<$resource> will be passed as desired
resource on resource binding.

Note: You have to take care that the stringprep profile for
resources can be applied at: C<$resource>. Otherwise the server
might signal an error. See L<Net::XMPP2::Util> for utility functions
to check this.

=item domain => $domain

This is the destination host we are going to connect to.
As the connection won't be automatically connected use C<connect>
to initiate the connect.

Note: A SRV RR lookup will be performed to discover the real hostname
and port to connect to. See also C<connect>.

=item port => $port

This is optional, the default port is 5222.

Note: A SRV RR lookup will be performed to discover the real hostname
and port to connect to. See also C<connect>.

=item username => $username

This is your C<$username> (the userpart in the JID);

Note: You have to take care that the stringprep profile for
nodes can be applied at: C<$username>. Otherwise the server
might signal an error. See L<Net::XMPP2::Util> for utility functions
to check this.

=item password => $password

This is the password for the C<username> above.

=back

=cut

sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   my $self = {  language => 'en', @_ };
   bless $self, $class;

   $self->{parser} = new Net::XMPP2::Parser;
   $self->{writer} = Net::XMPP2::Writer->new (
      write_cb => sub { $self->write_data ($_[0]) }
   );

   $self->{parser}->set_stanza_cb (sub {
      $self->handle_stanza (@_);
   });

   $self->{iq_id} = 1;

   $self->{disconnect_cb} = sub {
      my ($host, $port, $message) = @_;
      $self->event (disconnect => $host, $port, $message);
   };

   return $self;
}

=head2 connect ($no_srv_rr)

Try to connect to the domain and port passed in C<new>.

A SRV RR lookup will be performed on the domain to discover
the host and port to use. If you don't want this set C<$no_srv_rr>
to a true value. C<$no_srv_rr> is false by default.

As the SRV RR lookup might return multiple host and you fail to
connect to one you might just call this function again to try a
different host.

If C<connect> was successful and we connected a true value is returned.
If the connect was unsuccessful undef is returned and C<$!> will be set
to the error that occured while connecting.

If you want to know whether further connection attempts might be more
successful (as SRV RR lookup may return multiple hosts) call C<may_try_connect>
(see also C<may_try_connect>).

Note that an internal list will be kept of tried hosts.  Use
C<reset_connect_tries> to reset the internal list of tried hosts.

=cut

sub connect {
   my ($self, $no_srv_rr) = @_;

   my ($host, $port) = ($self->{domain}, $self->{port} || 5222);

   unless ($no_srv_rr) {
      my $res = Net::DNS::Resolver->new;
      my $p   = $res->query ('_xmpp-client._tcp.'.$host, 'SRV');
      if ($p) {
         my @srvs = grep { $_->type eq 'SRV' } $p->answer;
         if (@srvs) {
            @srvs = sort { $a->priority <=> $b->priority } @srvs;
            @srvs = sort { $b->weight <=> $a->weight } @srvs; # TODO
            $port = $srvs[0]->port;
            $host = $srvs[0]->target;
         }
      }
   }

   if ($self->SUPER::connect ($host, $port)) {
      $self->event (connect => $host, $port);
      return 1;
   } else {
      return undef;
   }
}

=head2 may_try_connect

Returns the number of left alternatives of hosts to connect to for the
domain passed to C<new>.

An internal list of tried hosts will be managed by C<connect> and those
hosts will be ignored by a SRV RR lookup (which will be done if you
call this function).

Use C<reset_connect_tries> to reset the internal list of tried hosts.

=cut

sub may_try_connect {
   # TODO
}

=head2 reset_connect_tries

This function resets the internal list of tried hosts for C<connect>.
See also C<connect>.

=cut

sub reset_connect_tries {
   # TODO
}

sub handle_data {
   my ($self, $buf) = @_;
   $self->event (debug_recv => $$buf);
   $self->{parser}->feed (substr $$buf, 0, (length $$buf), '');
}

sub write_data {
   my ($self, $data) = @_;
   $self->event (debug_send => $data);
   $self->SUPER::write_data ($data);
}

=item reg_cb ($eventname1, $cb1, [$eventname2, $cb2, ...])

This method registers a callback C<$cb1> for the event with the
name C<$eventname1>. You can also pass multiple of these eventname => callback
pairs.

To see a documentation of emitted events please take a look at the EVENTS section
below.

=cut

sub reg_cb {
   my ($self, %regs) = @_;

   for my $cmd (keys %regs) {
      my $cb = $regs{$cmd};
      push @{$self->{events}->{$cmd}}, $cb;
   }

   1;
}

sub event {
   my ($self, $ev, @arg) = @_;

   my $nxt = [];

   for (@{$self->{events}->{lc $ev}}) {
      $_->($self, @arg) and push @$nxt, $_;
   }

   $self->{events}->{lc $ev} = $nxt;
}

sub handle_stanza {
   my ($self, $p, $node) = @_;

   if ($node->eq (stream => 'features')) {
      $self->event (stream_features => $node);
      $self->handle_stream_features ($node);
   } elsif ($node->eq (sasl => 'challenge')) {
      $self->handle_sasl_challenge ($node);
   } elsif ($node->eq (sasl => 'success')) {
      $self->handle_sasl_success ($node);
   } elsif ($node->eq (client => 'iq')) {
      $self->handle_iq ($node);
   } elsif ($node->eq (stream => 'error')) {
      $self->handle_error ($node);
   } else {
      warn "Didn't understood stanza: '" . $node->name . "'";
   }
}

=head2 init ($domain)

Initiate the XML stream.

=cut

sub init {
   my ($self) = @_;
   $self->{writer}->send_init_stream ($self->{language}, $self->{domain});
}

=head2 send_iq ($type, $create_cb, $result_cb, %attrs)

This method sends an IQ XMPP request.

Please take a look at the documentation for C<send_iq> in Net::XMPP2::Writer
about the meaning of C<$type>, C<$create_cb> and C<%attrs>.

C<$result_cb> will be called when a result was received. The first argument
to C<$result_cb> will be a Net::XMPP2::Parser instance and the second
will be a Net::XMPP2::Node instance containing the IQ result stanza contents.

If the IQ resulted in a stanza error the second argument to C<$result_cb> will
be C<undef> (if the error type was not 'continue') and the third argument will
be a Net::XMPP2::Node containg the IQ error stanza. And the fourth argument
will be a array reference with following contents:

=over 4

=item index 0: error type

This will be one of: 'cancel', 'continue', 'modify', 'auth' and 'wait'.

=item index 1: error condition element

This might be undefined if other XMPP speakers don't play nice i guess.

=item index 2: error text

This will be the human readable form of the error which is maybe undef if
not supplied.

=item index 3: error code

If the error element had an 'code' attribute it will be put here,
the RFC says that this is for backward compatibility :)

=back

=cut

sub send_iq {
   my ($self, $type, $create_cb, $result_cb, %attrs) = @_;
   my $id = $self->{iq_id}++;
   $self->{iqs}->{$id} = $result_cb;
   $self->{writer}->send_iq ($id, $type, $create_cb, %attrs);
}

sub handle_iq {
   my ($self, $node) = @_;

   if ($node->attr ('type') eq 'result') {
      if (my $cb = $self->{iqs}->{$node->attr ('id')}) {
         $cb->($node);
      }
   } elsif ($node->attr ('type') eq 'error') {
      if (my $cb = $self->{iqs}->{$node->attr ('id')}) {

         my $error = $self->filter_error_stanza ($node);
         $cb->(($error->[0] eq 'continue' ? $node : undef), $node, $error);
      }
   }
}

sub filter_error_stanza {
   my ($self, $node) = @_;
   my $p = $self->{parser};
   my @error;
   my ($err) = $node->find_all ([qw/client error/]);
   $error[0] = $err->attr ('type');
   $error[3] = $err->attr ('code');
   if ($err) {
      if (my ($txt) = $err->find_all ([qw/stanzas text/])) {
         $error[2] = $txt->text;
      }
      for my $er (
        qw/bad-request conflict feature-not-implemented forbidden
           gone internal-server-error item-not-found jid-malformed
           not-acceptable not-allowed not-authorized payment-required
           recipient-unavailable redirect registration-required
           remote-server-not-found remote-server-timeout resource-constraint
           service-unavailable subscription-required undefined-condition
           unexpected-request/)
      {
         if (my ($el) = $err->find_all ([stanzas => $er])) {
            $error[1] = $el;
            last;
         }
      }
   } else {
      warn "no error element found in error stanza!";
   }
   return \@error
}

sub handle_stream_features {
   my ($self, $node) = @_;
   my @mechs = $node->find_all ([qw/sasl mechanisms/], [qw/sasl mechanism/]);
   my @bind  = $node->find_all ([qw/bind bind/]);

   if (not ($self->{authenticated}) and @mechs) {
      $self->{writer}->send_sasl_auth (
         (join ' ', map { $_->text } @mechs),
         $self->{username}, $self->{domain}, $self->{password}
      );

   } elsif (@bind) {
      $self->do_rebind ($self->{resource});
   }
}

sub handle_sasl_challenge {
   my ($self, $node) = @_;
   $self->{writer}->send_sasl_response ($node->text);
}

sub handle_sasl_success {
   my ($self, $node) = @_;
   $self->{authenticated} = 1;
   $self->{parser}->init;
   $self->{writer}->init;
   $self->{writer}->send_init_stream ($self->{language}, $self->{domain});
}

sub handle_error {
   my ($self, $node) = @_;
   my @txt = $node->find_all ([qw/stream text/]);
   my $error;
   for my $er (
      qw/bad-format bad-namespace-prefix conflict connection-timeout host-gone
         host-unknown improper-addressing internal-server-error invalid-from
         invalid-id invalid-namespace invalid-xml not-authorized policy-violation
         remote-connection-failed resource-constraint restricted-xml
         see-other-host system-shutdown undefined-condition unsupported-stanza-type
         unsupported-version xml-not-well-formed/)
   {
      for ($node->nodes) {
         if ($node->eq (streams => $er)) {
            $error = $_->name;
            last
         }
      }
   }
   unless ($error) {
      warn "got undefined error stanza, trying to find any undefined error...";
      for ($node->nodes) {
         if ($node->eq_ns ('streams')) {
            $error = $node->name;
         }
      }
   }
   $self->event (stream_error => $error, (@txt ? $txt[0]->text : ''));
   $self->{writer}->send_end_of_stream;
}

=head2 do_rebind ($resource)

In case you got a C<bind_error> event and want to retry
binding you can call this function to set a new C<$resource>
and retry binding.

If it fails again you can call this again. Becareful not to
end up in a loop!

If binding was successful the C<stream_ready> event will be generated.

=cut

sub do_rebind {
   my ($self, $resource) = @_;
   $self->{resource} = $resource;
   $self->send_iq (
      set =>
         sub {
            my ($w) = @_;
            if ($self->{resource}) {
               $w->startTag ([xmpp_ns ('bind'), 'bind']);
                  $w->startTag ([xmpp_ns ('bind'), 'resource']);
                  $w->characters ($self->{resource});
                  $w->endTag;
               $w->endTag;
            } else {
               $w->emptyTag ([xmpp_ns ('bind'), 'bind'])
            }
         },
         sub {
            my ($ret_iq, $err_iq, $err) = @_;

            if ($err) {
               my ($res) = $err_iq->find_all ([qw/bind bind/], [qw/bind resource/]);
               $self->event (bind_error => $err->[0], ($res ? $res : $self->{resource}));

            } else {
               my @jid = $ret_iq->find_all ([qw/bind bind/], [qw/bind jid/]);
               my $jid = $jid[0]->text;
               unless ($jid) { die "Got empty JID tag from server!\n" }
               $self->{jid} = $jid;

               $self->event (stream_ready => $jid);
            }
         }
   );
}

=head2 jid

After the stream has been bound to a resource the JID can be retrieved via this
method.

=cut

sub jid { $_[0]->{jid} }

=head1 EVENTS

These events can be registered on with C<reg_cb>:

=over 4

=item stream_features => $node

This 

=item stream_ready => $jid

This event is sent if the XML stream has been established (and
resources have been bound) and is ready for transmitting regular stanzas.

C<$jid> is the bound jabber id.

=item bind_error => $error_name, $resource

This event is generated when the stream was unable to bind to
any or the in C<new> specified resource. C<$error_name>
may be 'bad-request', 'not-allowed' or 'conflict'.

Node: this is untested, i couldn't get the server to send a bind error
to test this.

=item connect => $host, $port

This event is generated when a successful connect was performed to
the domain passed to C<new>.

Note: C<$host> and C<$port> might be different from the domain you passed to
C<new> if C<connect> performed a SRV RR lookup.

If this connection is lost a C<disconnect> will be generated with the same
C<$host> and C<$port>.

=item disconnect => $host, $port, $message

This event is generated when the connection was lost or another error
occured while writing or reading from it.

C<$message> is a humand readable error message for the failure.
C<$host> and C<$port> were the host and port we were connected to.

Note: C<$host> and C<$port> might be different from the domain you passed to
C<new> if C<connect> performed a SRV RR lookup.

=back

=head1 AUTHOR

Robin Redeker, C<< <elmex at ta-sa.org> >>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-net-xmpp2 at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-XMPP2>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Net::XMPP2

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Net-XMPP2>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Net-XMPP2>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-XMPP2>

=item * Search CPAN

L<http://search.cpan.org/dist/Net-XMPP2>

=back

=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2007 Robin Redeker, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

package Net::XMPP2::SimpleConnection;
use IO::Socket::INET;
use Fcntl;

sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   my $self = { disconnect_cb => sub {}, @_ };
   bless $self, $class;
   return $self;
}

sub connect {
   my ($self, $host, $port) = @_;

   $self->{socket}
      and return 1;

   my $sock = IO::Socket::INET->new (
      PeerAddr => $host,
      PeerPort => $port,
      Proto    => 'tcp',
      Blocking => 1
   );
   return undef unless $sock;;

   $self->{socket} = $sock;
   $self->{host}   = $host;
   $self->{port}   = $port;

   my $flags = 0;
   fcntl($sock, F_GETFL, $flags)
       or die "Couldn't get flags for HANDLE : $!\n";
   $flags |= O_NONBLOCK;
   fcntl($sock, F_SETFL, $flags)
       or die "Couldn't set flags for HANDLE: $!\n";

   binmode $sock, ":utf8";

   $self->{r} =
      AnyEvent->io (poll => 'r', fh => $sock, cb => sub {
         my $l = sysread $sock, my $data, 1024;

         $self->{read_buffer} .= $data;
         $self->handle_data (\$self->{read_buffer});

         unless ($l) {
            if (defined $l) {
               $self->{disconnect_cb}->($host, $port, "EOF from server '$host:$port'");
               delete $self->{r};
               delete $self->{socket};
               return;

            } else {
               $self->{disconnect_cb}->($host, $port, "Error while reading from server '$host:$port': $!");
               delete $self->{socket};
               delete $self->{r};
               return;
            }
         }
      });
   return 1;
}

sub write_data {
   my ($self, $data) = @_;
   return unless $self->{r};

   my $cl = $self->{socket};
   $self->{write_buffer} .= $data;

   unless ($self->{w}) {
      $self->{w} =
         AnyEvent->io (poll => 'w', fh => $cl, cb => sub {
            if (my $data = $self->{write_buffer}) {
               my $len = syswrite $cl, $data;
               unless ($len) {
                  if (not defined $len) {
                     warn "error when writing data on $self->{host}:$self->{port}: $!";
                     return;
                  } else {
                     delete $self->{w};
                  }
               }

               if ($len == length $self->{write_buffer}) {
                  delete $self->{w};
               }

               $self->{write_buffer} = substr $self->{write_buffer}, $len;
            }
         });
   }
}

1; # End of Net::XMPP2
Revision:	1.1
Committed:	Tue Jan 23 15:56:47 2007 UTC (19 years, 8 months ago) by elmex
Branch:	MAIN
Log Message:	initial checkin.
#	User	Rev	Content
1	elmex	1.1	package Net::XMPP2::Connection;
2			use warnings;
3			use strict;
4			use AnyEvent;
5			use IO::Socket::INET;
6			use Net::XMPP2::Parser;
7			use Net::XMPP2::Writer;
8			use Net::XMPP2::Util;
9			use Net::XMPP2::Namespaces qw/xmpp_ns/;
10			use Net::DNS;
11
12			our @ISA = qw/Net::XMPP2::SimpleConnection/;
13
14			=head1 NAME
15
16			Net::XMPP2::Connection - A XML stream that implements the XMPP RFC 3920.
17
18			=head1 SYNOPSIS
19
20			use Net::XMPP2::Connection;
21
22			my $con =
23			Net::XMPP2::Connection->new (
24			username => "abc",
25			domain => "jabber.org",
26			resource => "Net::XMPP2"
27			);
28
29			$con->connect or die "Couldn't connect to jabber.org: $!";
30			$con->init;
31			$con->reg_cb (stream_ready => sub { print "XMPP stream ready!\n" });
32
33			=head1 DESCRIPTION
34
35			This module represents a XMPP stream as described in RFC 3920. You can issue the basic
36			XMPP XML stanzas with methods like C<send_iq>, C<send_message> and C<send_presence>.
37
38			And receive events with the C<reg_cb> event framework from the connection.
39
40			If you need instant messaging stuff please take a look at C<Net::XMPP2::IM::Connection>.
41
42			=head1 METHODS
43
44			=head2 new (%args)
45
46			Following arguments can be passed in C<%args>:
47
48			=over 4
49
50			=item language => $tag
51
52			This should be the language of the human readable contents that
53			will be transmitted over the stream. The default will be 'en'.
54
55			Please look in RFC 3066 how C<$tag> should look like.
56
57			=item resource => $resource
58
59			If this argument is given C<$resource> will be passed as desired
60			resource on resource binding.
61
62			Note: You have to take care that the stringprep profile for
63			resources can be applied at: C<$resource>. Otherwise the server
64			might signal an error. See L<Net::XMPP2::Util> for utility functions
65			to check this.
66
67			=item domain => $domain
68
69			This is the destination host we are going to connect to.
70			As the connection won't be automatically connected use C<connect>
71			to initiate the connect.
72
73			Note: A SRV RR lookup will be performed to discover the real hostname
74			and port to connect to. See also C<connect>.
75
76			=item port => $port
77
78			This is optional, the default port is 5222.
79
80			Note: A SRV RR lookup will be performed to discover the real hostname
81			and port to connect to. See also C<connect>.
82
83			=item username => $username
84
85			This is your C<$username> (the userpart in the JID);
86
87			Note: You have to take care that the stringprep profile for
88			nodes can be applied at: C<$username>. Otherwise the server
89			might signal an error. See L<Net::XMPP2::Util> for utility functions
90			to check this.
91
92			=item password => $password
93
94			This is the password for the C<username> above.
95
96			=back
97
98			=cut
99
100			sub new {
101			my $this = shift;
102			my $class = ref($this) \|\| $this;
103			my $self = { language => 'en', @_ };
104			bless $self, $class;
105
106			$self->{parser} = new Net::XMPP2::Parser;
107			$self->{writer} = Net::XMPP2::Writer->new (
108			write_cb => sub { $self->write_data ($_[0]) }
109			);
110
111			$self->{parser}->set_stanza_cb (sub {
112			$self->handle_stanza (@_);
113			});
114
115			$self->{iq_id} = 1;
116
117			$self->{disconnect_cb} = sub {
118			my ($host, $port, $message) = @_;
119			$self->event (disconnect => $host, $port, $message);
120			};
121
122			return $self;
123			}
124
125			=head2 connect ($no_srv_rr)
126
127			Try to connect to the domain and port passed in C<new>.
128
129			A SRV RR lookup will be performed on the domain to discover
130			the host and port to use. If you don't want this set C<$no_srv_rr>
131			to a true value. C<$no_srv_rr> is false by default.
132
133			As the SRV RR lookup might return multiple host and you fail to
134			connect to one you might just call this function again to try a
135			different host.
136
137			If C<connect> was successful and we connected a true value is returned.
138			If the connect was unsuccessful undef is returned and C<$!> will be set
139			to the error that occured while connecting.
140
141			If you want to know whether further connection attempts might be more
142			successful (as SRV RR lookup may return multiple hosts) call C<may_try_connect>
143			(see also C<may_try_connect>).
144
145			Note that an internal list will be kept of tried hosts. Use
146			C<reset_connect_tries> to reset the internal list of tried hosts.
147
148			=cut
149
150			sub connect {
151			my ($self, $no_srv_rr) = @_;
152
153			my ($host, $port) = ($self->{domain}, $self->{port} \|\| 5222);
154
155			unless ($no_srv_rr) {
156			my $res = Net::DNS::Resolver->new;
157			my $p = $res->query ('_xmpp-client._tcp.'.$host, 'SRV');
158			if ($p) {
159			my @srvs = grep { $_->type eq 'SRV' } $p->answer;
160			if (@srvs) {
161			@srvs = sort { $a->priority <=> $b->priority } @srvs;
162			@srvs = sort { $b->weight <=> $a->weight } @srvs; # TODO
163			$port = $srvs[0]->port;
164			$host = $srvs[0]->target;
165			}
166			}
167			}
168
169			if ($self->SUPER::connect ($host, $port)) {
170			$self->event (connect => $host, $port);
171			return 1;
172			} else {
173			return undef;
174			}
175			}
176
177			=head2 may_try_connect
178
179			Returns the number of left alternatives of hosts to connect to for the
180			domain passed to C<new>.
181
182			An internal list of tried hosts will be managed by C<connect> and those
183			hosts will be ignored by a SRV RR lookup (which will be done if you
184			call this function).
185
186			Use C<reset_connect_tries> to reset the internal list of tried hosts.
187
188			=cut
189
190			sub may_try_connect {
191			# TODO
192			}
193
194			=head2 reset_connect_tries
195
196			This function resets the internal list of tried hosts for C<connect>.
197			See also C<connect>.
198
199			=cut
200
201			sub reset_connect_tries {
202			# TODO
203			}
204
205			sub handle_data {
206			my ($self, $buf) = @_;
207			$self->event (debug_recv => $$buf);
208			$self->{parser}->feed (substr $$buf, 0, (length $$buf), '');
209			}
210
211			sub write_data {
212			my ($self, $data) = @_;
213			$self->event (debug_send => $data);
214			$self->SUPER::write_data ($data);
215			}
216
217			=item reg_cb ($eventname1, $cb1, [$eventname2, $cb2, ...])
218
219			This method registers a callback C<$cb1> for the event with the
220			name C<$eventname1>. You can also pass multiple of these eventname => callback
221			pairs.
222
223			To see a documentation of emitted events please take a look at the EVENTS section
224			below.
225
226			=cut
227
228			sub reg_cb {
229			my ($self, %regs) = @_;
230
231			for my $cmd (keys %regs) {
232			my $cb = $regs{$cmd};
233			push @{$self->{events}->{$cmd}}, $cb;
234			}
235
236			1;
237			}
238
239			sub event {
240			my ($self, $ev, @arg) = @_;
241
242			my $nxt = [];
243
244			for (@{$self->{events}->{lc $ev}}) {
245			$_->($self, @arg) and push @$nxt, $_;
246			}
247
248			$self->{events}->{lc $ev} = $nxt;
249			}
250
251			sub handle_stanza {
252			my ($self, $p, $node) = @_;
253
254			if ($node->eq (stream => 'features')) {
255			$self->event (stream_features => $node);
256			$self->handle_stream_features ($node);
257			} elsif ($node->eq (sasl => 'challenge')) {
258			$self->handle_sasl_challenge ($node);
259			} elsif ($node->eq (sasl => 'success')) {
260			$self->handle_sasl_success ($node);
261			} elsif ($node->eq (client => 'iq')) {
262			$self->handle_iq ($node);
263			} elsif ($node->eq (stream => 'error')) {
264			$self->handle_error ($node);
265			} else {
266			warn "Didn't understood stanza: '" . $node->name . "'";
267			}
268			}
269
270			=head2 init ($domain)
271
272			Initiate the XML stream.
273
274			=cut
275
276			sub init {
277			my ($self) = @_;
278			$self->{writer}->send_init_stream ($self->{language}, $self->{domain});
279			}
280
281			=head2 send_iq ($type, $create_cb, $result_cb, %attrs)
282
283			This method sends an IQ XMPP request.
284
285			Please take a look at the documentation for C<send_iq> in Net::XMPP2::Writer
286			about the meaning of C<$type>, C<$create_cb> and C<%attrs>.
287
288			C<$result_cb> will be called when a result was received. The first argument
289			to C<$result_cb> will be a Net::XMPP2::Parser instance and the second
290			will be a Net::XMPP2::Node instance containing the IQ result stanza contents.
291
292			If the IQ resulted in a stanza error the second argument to C<$result_cb> will
293			be C<undef> (if the error type was not 'continue') and the third argument will
294			be a Net::XMPP2::Node containg the IQ error stanza. And the fourth argument
295			will be a array reference with following contents:
296
297			=over 4
298
299			=item index 0: error type
300
301			This will be one of: 'cancel', 'continue', 'modify', 'auth' and 'wait'.
302
303			=item index 1: error condition element
304
305			This might be undefined if other XMPP speakers don't play nice i guess.
306
307			=item index 2: error text
308
309			This will be the human readable form of the error which is maybe undef if
310			not supplied.
311
312			=item index 3: error code
313
314			If the error element had an 'code' attribute it will be put here,
315			the RFC says that this is for backward compatibility :)
316
317			=back
318
319			=cut
320
321			sub send_iq {
322			my ($self, $type, $create_cb, $result_cb, %attrs) = @_;
323			my $id = $self->{iq_id}++;
324			$self->{iqs}->{$id} = $result_cb;
325			$self->{writer}->send_iq ($id, $type, $create_cb, %attrs);
326			}
327
328			sub handle_iq {
329			my ($self, $node) = @_;
330
331			if ($node->attr ('type') eq 'result') {
332			if (my $cb = $self->{iqs}->{$node->attr ('id')}) {
333			$cb->($node);
334			}
335			} elsif ($node->attr ('type') eq 'error') {
336			if (my $cb = $self->{iqs}->{$node->attr ('id')}) {
337
338			my $error = $self->filter_error_stanza ($node);
339			$cb->(($error->[0] eq 'continue' ? $node : undef), $node, $error);
340			}
341			}
342			}
343
344			sub filter_error_stanza {
345			my ($self, $node) = @_;
346			my $p = $self->{parser};
347			my @error;
348			my ($err) = $node->find_all ([qw/client error/]);
349			$error[0] = $err->attr ('type');
350			$error[3] = $err->attr ('code');
351			if ($err) {
352			if (my ($txt) = $err->find_all ([qw/stanzas text/])) {
353			$error[2] = $txt->text;
354			}
355			for my $er (
356			qw/bad-request conflict feature-not-implemented forbidden
357			gone internal-server-error item-not-found jid-malformed
358			not-acceptable not-allowed not-authorized payment-required
359			recipient-unavailable redirect registration-required
360			remote-server-not-found remote-server-timeout resource-constraint
361			service-unavailable subscription-required undefined-condition
362			unexpected-request/)
363			{
364			if (my ($el) = $err->find_all ([stanzas => $er])) {
365			$error[1] = $el;
366			last;
367			}
368			}
369			} else {
370			warn "no error element found in error stanza!";
371			}
372			return \@error
373			}
374
375			sub handle_stream_features {
376			my ($self, $node) = @_;
377			my @mechs = $node->find_all ([qw/sasl mechanisms/], [qw/sasl mechanism/]);
378			my @bind = $node->find_all ([qw/bind bind/]);
379
380			if (not ($self->{authenticated}) and @mechs) {
381			$self->{writer}->send_sasl_auth (
382			(join ' ', map { $_->text } @mechs),
383			$self->{username}, $self->{domain}, $self->{password}
384			);
385
386			} elsif (@bind) {
387			$self->do_rebind ($self->{resource});
388			}
389			}
390
391			sub handle_sasl_challenge {
392			my ($self, $node) = @_;
393			$self->{writer}->send_sasl_response ($node->text);
394			}
395
396			sub handle_sasl_success {
397			my ($self, $node) = @_;
398			$self->{authenticated} = 1;
399			$self->{parser}->init;
400			$self->{writer}->init;
401			$self->{writer}->send_init_stream ($self->{language}, $self->{domain});
402			}
403
404			sub handle_error {
405			my ($self, $node) = @_;
406			my @txt = $node->find_all ([qw/stream text/]);
407			my $error;
408			for my $er (
409			qw/bad-format bad-namespace-prefix conflict connection-timeout host-gone
410			host-unknown improper-addressing internal-server-error invalid-from
411			invalid-id invalid-namespace invalid-xml not-authorized policy-violation
412			remote-connection-failed resource-constraint restricted-xml
413			see-other-host system-shutdown undefined-condition unsupported-stanza-type
414			unsupported-version xml-not-well-formed/)
415			{
416			for ($node->nodes) {
417			if ($node->eq (streams => $er)) {
418			$error = $_->name;
419			last
420			}
421			}
422			}
423			unless ($error) {
424			warn "got undefined error stanza, trying to find any undefined error...";
425			for ($node->nodes) {
426			if ($node->eq_ns ('streams')) {
427			$error = $node->name;
428			}
429			}
430			}
431			$self->event (stream_error => $error, (@txt ? $txt[0]->text : ''));
432			$self->{writer}->send_end_of_stream;
433			}
434
435			=head2 do_rebind ($resource)
436
437			In case you got a C<bind_error> event and want to retry
438			binding you can call this function to set a new C<$resource>
439			and retry binding.
440
441			If it fails again you can call this again. Becareful not to
442			end up in a loop!
443
444			If binding was successful the C<stream_ready> event will be generated.
445
446			=cut
447
448			sub do_rebind {
449			my ($self, $resource) = @_;
450			$self->{resource} = $resource;
451			$self->send_iq (
452			set =>
453			sub {
454			my ($w) = @_;
455			if ($self->{resource}) {
456			$w->startTag ([xmpp_ns ('bind'), 'bind']);
457			$w->startTag ([xmpp_ns ('bind'), 'resource']);
458			$w->characters ($self->{resource});
459			$w->endTag;
460			$w->endTag;
461			} else {
462			$w->emptyTag ([xmpp_ns ('bind'), 'bind'])
463			}
464			},
465			sub {
466			my ($ret_iq, $err_iq, $err) = @_;
467
468			if ($err) {
469			my ($res) = $err_iq->find_all ([qw/bind bind/], [qw/bind resource/]);
470			$self->event (bind_error => $err->[0], ($res ? $res : $self->{resource}));
471
472			} else {
473			my @jid = $ret_iq->find_all ([qw/bind bind/], [qw/bind jid/]);
474			my $jid = $jid[0]->text;
475			unless ($jid) { die "Got empty JID tag from server!\n" }
476			$self->{jid} = $jid;
477
478			$self->event (stream_ready => $jid);
479			}
480			}
481			);
482			}
483
484			=head2 jid
485
486			After the stream has been bound to a resource the JID can be retrieved via this
487			method.
488
489			=cut
490
491			sub jid { $_[0]->{jid} }
492
493			=head1 EVENTS
494
495			These events can be registered on with C<reg_cb>:
496
497			=over 4
498
499			=item stream_features => $node
500
501			This
502
503			=item stream_ready => $jid
504
505			This event is sent if the XML stream has been established (and
506			resources have been bound) and is ready for transmitting regular stanzas.
507
508			C<$jid> is the bound jabber id.
509
510			=item bind_error => $error_name, $resource
511
512			This event is generated when the stream was unable to bind to
513			any or the in C<new> specified resource. C<$error_name>
514			may be 'bad-request', 'not-allowed' or 'conflict'.
515
516			Node: this is untested, i couldn't get the server to send a bind error
517			to test this.
518
519			=item connect => $host, $port
520
521			This event is generated when a successful connect was performed to
522			the domain passed to C<new>.
523
524			Note: C<$host> and C<$port> might be different from the domain you passed to
525			C<new> if C<connect> performed a SRV RR lookup.
526
527			If this connection is lost a C<disconnect> will be generated with the same
528			C<$host> and C<$port>.
529
530			=item disconnect => $host, $port, $message
531
532			This event is generated when the connection was lost or another error
533			occured while writing or reading from it.
534
535			C<$message> is a humand readable error message for the failure.
536			C<$host> and C<$port> were the host and port we were connected to.
537
538			Note: C<$host> and C<$port> might be different from the domain you passed to
539			C<new> if C<connect> performed a SRV RR lookup.
540
541			=back
542
543			=head1 AUTHOR
544
545			Robin Redeker, C<< <elmex at ta-sa.org> >>
546
547			=head1 BUGS
548
549			Please report any bugs or feature requests to
550			C<bug-net-xmpp2 at rt.cpan.org>, or through the web interface at
551			L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-XMPP2>.
552			I will be notified, and then you'll automatically be notified of progress on
553			your bug as I make changes.
554
555			=head1 SUPPORT
556
557			You can find documentation for this module with the perldoc command.
558
559			perldoc Net::XMPP2
560
561			You can also look for information at:
562
563			=over 4
564
565			=item * AnnoCPAN: Annotated CPAN documentation
566
567			L<http://annocpan.org/dist/Net-XMPP2>
568
569			=item * CPAN Ratings
570
571			L<http://cpanratings.perl.org/d/Net-XMPP2>
572
573			=item * RT: CPAN's request tracker
574
575			L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-XMPP2>
576
577			=item * Search CPAN
578
579			L<http://search.cpan.org/dist/Net-XMPP2>
580
581			=back
582
583			=head1 ACKNOWLEDGEMENTS
584
585			=head1 COPYRIGHT & LICENSE
586
587			Copyright 2007 Robin Redeker, all rights reserved.
588
589			This program is free software; you can redistribute it and/or modify it
590			under the same terms as Perl itself.
591
592			=cut
593
594			package Net::XMPP2::SimpleConnection;
595			use IO::Socket::INET;
596			use Fcntl;
597
598			sub new {
599			my $this = shift;
600			my $class = ref($this) \|\| $this;
601			my $self = { disconnect_cb => sub {}, @_ };
602			bless $self, $class;
603			return $self;
604			}
605
606			sub connect {
607			my ($self, $host, $port) = @_;
608
609			$self->{socket}
610			and return 1;
611
612			my $sock = IO::Socket::INET->new (
613			PeerAddr => $host,
614			PeerPort => $port,
615			Proto => 'tcp',
616			Blocking => 1
617			);
618			return undef unless $sock;;
619
620			$self->{socket} = $sock;
621			$self->{host} = $host;
622			$self->{port} = $port;
623
624			my $flags = 0;
625			fcntl($sock, F_GETFL, $flags)
626			or die "Couldn't get flags for HANDLE : $!\n";
627			$flags \|= O_NONBLOCK;
628			fcntl($sock, F_SETFL, $flags)
629			or die "Couldn't set flags for HANDLE: $!\n";
630
631			binmode $sock, ":utf8";
632
633			$self->{r} =
634			AnyEvent->io (poll => 'r', fh => $sock, cb => sub {
635			my $l = sysread $sock, my $data, 1024;
636
637			$self->{read_buffer} .= $data;
638			$self->handle_data (\$self->{read_buffer});
639
640			unless ($l) {
641			if (defined $l) {
642			$self->{disconnect_cb}->($host, $port, "EOF from server '$host:$port'");
643			delete $self->{r};
644			delete $self->{socket};
645			return;
646
647			} else {
648			$self->{disconnect_cb}->($host, $port, "Error while reading from server '$host:$port': $!");
649			delete $self->{socket};
650			delete $self->{r};
651			return;
652			}
653			}
654			});
655			return 1;
656			}
657
658			sub write_data {
659			my ($self, $data) = @_;
660			return unless $self->{r};
661
662			my $cl = $self->{socket};
663			$self->{write_buffer} .= $data;
664
665			unless ($self->{w}) {
666			$self->{w} =
667			AnyEvent->io (poll => 'w', fh => $cl, cb => sub {
668			if (my $data = $self->{write_buffer}) {
669			my $len = syswrite $cl, $data;
670			unless ($len) {
671			if (not defined $len) {
672			warn "error when writing data on $self->{host}:$self->{port}: $!";
673			return;
674			} else {
675			delete $self->{w};
676			}
677			}
678
679			if ($len == length $self->{write_buffer}) {
680			delete $self->{w};
681			}
682
683			$self->{write_buffer} = substr $self->{write_buffer}, $len;
684			}
685			});
686			}
687			}
688
689			1; # End of Net::XMPP2