XMPP2/IM/Connection.pm

package Net::XMPP2::IM::Connection;
use strict;
use Net::XMPP2::Connection;
use Net::XMPP2::Namespaces qw/xmpp_ns/;
use Net::XMPP2::IM::Roster;
use Net::XMPP2::IM::Message;
our @ISA = qw/Net::XMPP2::Connection/;

=head1 NAME

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

=head1 SYNOPSIS

   use Net::XMPP2::Connection;

   my $con = Net::XMPP2::Connection->new;

=head1 DESCRIPTION

This module represents a XMPP instant messaging connection and implements
RFC 3921.

This module is a subclass of C<Net::XMPP2::Connection> and inherits all methods.
For example C<reg_cb> and the stanza sending routines.

For additional events that can be registered to look below in the EVENTS section.

=head1 METHODS

=cut

=head2 new (%args)

This is the constructor. It takes the same arguments as
the constructor of L<Net::XMPP2::Connection> along with a
few others:

=over 4

=item dont_retrieve_roster => $bool

Set this to a true value if no roster should be requested on connection
establishment. You can retrieve the roster later if you want to
with the C<retrieve_roster> method.

The internal roster will be set even if this option is active, and
even presences will be stored in there, except that the C<get_contacts>
method on the roster object won't return anything as there are
no roster items.

=back

=cut

sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   my $self = $class->SUPER::new (@_);

   $self->{ext} = {}; # reserved for extensions
   $self->{roster} = Net::XMPP2::IM::Roster->new (connection => $self);

   $self->reg_cb (message_xml =>
      sub { shift @_; $self->handle_message (@_);    1 });
   $self->reg_cb (presence_xml =>
      sub { shift @_; $self->handle_presence (@_);   1 });
   $self->reg_cb (iq_set_request_xml =>
      sub { shift @_; $self->handle_iq_set (@_);     1 });
   $self->reg_cb (disconnect =>
      sub { shift @_; $self->handle_disconnect (@_); 1 });

   $self->reg_cb (stream_ready => sub {
      my ($jid) = @_;
      if ($self->features ()->find_all ([qw/session session/])) {
         $self->send_session_iq;
      } else {
         $self->init_connection;
      }
   });
   $self
}

sub send_session_iq {
   my ($self) = @_;

   $self->send_iq (set => sub {
      my ($w) = @_;
      $w->addPrefix (xmpp_ns ('session'), '');
      $w->emptyTag ([xmpp_ns ('session'), 'session']);

   }, sub {
      my ($node, $errnode, $errar) = @_;
      if ($node) {
         $self->init_connection;
      } else {
         $self->event (session_error => $errnode, $errar); # TODO: make error obj
      }
   });
}

sub init_connection {
   my ($self) = @_;
   $self->{session_active} = 1;
   if ($self->{dont_retrieve_roster}) {
      $self->send_presence;
   } else {
      $self->retrieve_roster (1);
   }
   $self->event ('session_ready');
}

sub retrieve_roster {
   my ($self, $init) = @_;

   $self->send_iq (get => sub {
      my ($w) = @_;
      $w->addPrefix (xmpp_ns ('roster'), '');
      $w->emptyTag ([xmpp_ns ('roster'), 'query']);

   }, sub {
      my ($node, $errnode, $errar) = @_;
      if ($node) {
         $self->store_roster ($node);
      } else {
         $self->event (roster_error => $errnode, $errar); # TODO: make error obj
      }

      $self->send_presence if $init;
   });
}

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

   my ($query) = $node->find_all ([qw/roster query/]);
   return unless $query;

   my @upd;

   for my $item ($query->find_all ([qw/roster item/])) {
      my ($jid, $name, $subscription) =
         ($item->attr ('jid'), $item->attr ('name'), $item->attr ('subscription'));
      my @groups;
      push @groups, $_->text for $item->find_all ([qw/roster group/]);

      push @upd,
         $self->{roster}->set_contact ($jid,
            name         => $name,
            subscription => $subscription,
            groups       => [ @groups ]
         );
   }

   $self->event (roster_update => $self->{roster}, \@upd);
}

sub get_roster {
   my ($self) = @_;
   $self->{roster}
}

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

   if ($node->find_all ([qw/roster query/])) {
      $self->store_roster ($node);
      $self->reply_iq_result ($node, sub {});
   }
}

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

   my $type       = $node->attr ('type');
   my ($show)     = $node->find_all ([qw/client show/]);
   my ($priority) = $node->find_all ([qw/client priority/]);

   my $jid = $node->attr ('from');

   my %stati;
   $stati{$_->attr ('lang') || ''} = $_->text
      for $node->find_all ([qw/client status/]);

   my $old =
      $self->{roster}->set_presence ($jid,
         show     => $show     ? $show->text     : undef,
         priority => $priority ? $priority->text : undef,
         type     => $type,
         status   => \%stati,
      );

   my $new = $self->{roster}->get_contact ($jid)->get_presence ($jid);

   $self->event (presence_update => $self->{roster}, $self->{roster}->get_contact ($jid), $old, $new)
}

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

   my $from     = $node->attr ('from');
   my $to       = $node->attr ('to');
   my $type     = $node->attr ('type');
   my ($thread) = $node->find_all ([qw/client thread/]);

   my %bodies;
   my %subjects;

   $bodies{$_->attr ('lang') || ''} = $_->text
      for $node->find_all ([qw/client body/]);
   $subjects{$_->attr ('lang') || ''} = $_->text
      for $node->find_all ([qw/client subject/]);

   my $msg =
      Net::XMPP2::IM::Message->new (
         connection => $self,
         from       => $from,
         to         => $to,
         type       => $type,
         bodies     => \%bodies,
         subjects   => \%subjects,
         thread     => $thread
      );

   $self->event (message => $msg);
}

sub handle_disconnect {
   my ($self) = @_;
   delete $self->{roster};
}

=head1 EVENTS

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

=over 4

=item session_ready

This event is generated when the session has been fully established and
can be used to send around messages and other stuff.

=item session_error => $erriq, $errarr

If an error happened during establishment of the session this
event will be generated. C<$erriq> is the L<Net::XMPP2::Node> object
of the error iq tag and C<$errar> is an error array as described in
L<Net::XMPP2::Connection::send_iq> for error responses for iq requests.

=item roster_update => $roster, $contacts

This event is emitted when a roster update has been received.
C<$roster> is the L<Net::XMPP2::IM::Roster> object you get by
calling C<get_roster>.
C<$contacts> is an array reference of L<Net::XMPP2::IM::Contact> objects
which have changed.

=item presence_update => $roster, $contact, $old_presence, $new_presence

This event is emitted when the presence of a contact has changed.
C<$roster> is the L<Net::XMPP2::IM::Roster> object you get by
calling C<get_roster>.
C<$contact> is the L<Net::XMPP2::IM::Contact> object which presence status
has changed.
C<$old_presence> is a L<Net::XMPP2::IM::Presence> object which represents the
presence prior to the change.
C<$new_presence> is a L<Net::XMPP2::IM::Presence> object which represents the
presence after to the change.

=item message => $msg

This event is emitted when a message was received.
C<$msg> is a L<Net::XMPP2::IM::Message> object.

=back

=head1 AUTHOR

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

=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

1; # End of Net::XMPP2
Revision:	1.8
Committed:	Fri Apr 20 14:56:45 2007 UTC (19 years, 6 months ago) by elmex
Branch:	MAIN
Changes since 1.7:	+44 -13 lines
Log Message:	implemented Client.pm. Implemented error objects which simplyfied the error reporting.
#	User	Rev	Content
1	elmex	1.1	package Net::XMPP2::IM::Connection;
2			use strict;
3			use Net::XMPP2::Connection;
4			use Net::XMPP2::Namespaces qw/xmpp_ns/;
5	elmex	1.5	use Net::XMPP2::IM::Roster;
6	elmex	1.6	use Net::XMPP2::IM::Message;
7	elmex	1.1	our @ISA = qw/Net::XMPP2::Connection/;
8
9			=head1 NAME
10
11	elmex	1.5	Net::XMPP2::IM::Connection - A XML stream that implements the XMPP RFC 3921.
12	elmex	1.1
13			=head1 SYNOPSIS
14
15			use Net::XMPP2::Connection;
16
17			my $con = Net::XMPP2::Connection->new;
18
19			=head1 DESCRIPTION
20
21			This module represents a XMPP instant messaging connection and implements
22			RFC 3921.
23
24			This module is a subclass of C<Net::XMPP2::Connection> and inherits all methods.
25			For example C<reg_cb> and the stanza sending routines.
26
27			For additional events that can be registered to look below in the EVENTS section.
28
29			=head1 METHODS
30
31			=cut
32
33	elmex	1.7	=head2 new (%args)
34
35			This is the constructor. It takes the same arguments as
36			the constructor of L<Net::XMPP2::Connection> along with a
37			few others:
38
39			=over 4
40
41			=item dont_retrieve_roster => $bool
42
43			Set this to a true value if no roster should be requested on connection
44			establishment. You can retrieve the roster later if you want to
45			with the C<retrieve_roster> method.
46
47			The internal roster will be set even if this option is active, and
48			even presences will be stored in there, except that the C<get_contacts>
49			method on the roster object won't return anything as there are
50			no roster items.
51
52			=back
53
54			=cut
55
56	elmex	1.1	sub new {
57			my $this = shift;
58			my $class = ref($this) \|\| $this;
59			my $self = $class->SUPER::new (@_);
60	elmex	1.2
61			$self->{ext} = {}; # reserved for extensions
62	elmex	1.5	$self->{roster} = Net::XMPP2::IM::Roster->new (connection => $self);
63	elmex	1.2
64	elmex	1.5	$self->reg_cb (message_xml =>
65			sub { shift @_; $self->handle_message (@_); 1 });
66			$self->reg_cb (presence_xml =>
67			sub { shift @_; $self->handle_presence (@_); 1 });
68			$self->reg_cb (iq_set_request_xml =>
69			sub { shift @_; $self->handle_iq_set (@_); 1 });
70			$self->reg_cb (disconnect =>
71			sub { shift @_; $self->handle_disconnect (@_); 1 });
72	elmex	1.2
73	elmex	1.1	$self->reg_cb (stream_ready => sub {
74			my ($jid) = @_;
75	elmex	1.2	if ($self->features ()->find_all ([qw/session session/])) {
76			$self->send_session_iq;
77			} else {
78	elmex	1.7	$self->init_connection;
79	elmex	1.2	}
80	elmex	1.1	});
81			$self
82			}
83
84	elmex	1.2	sub send_session_iq {
85			my ($self) = @_;
86
87			$self->send_iq (set => sub {
88			my ($w) = @_;
89			$w->addPrefix (xmpp_ns ('session'), '');
90			$w->emptyTag ([xmpp_ns ('session'), 'session']);
91
92			}, sub {
93			my ($node, $errnode, $errar) = @_;
94			if ($node) {
95	elmex	1.7	$self->init_connection;
96	elmex	1.2	} else {
97	elmex	1.4	$self->event (session_error => $errnode, $errar); # TODO: make error obj
98	elmex	1.2	}
99			});
100			}
101
102	elmex	1.7	sub init_connection {
103			my ($self) = @_;
104			$self->{session_active} = 1;
105			if ($self->{dont_retrieve_roster}) {
106			$self->send_presence;
107			} else {
108			$self->retrieve_roster (1);
109			}
110			$self->event ('session_ready');
111			}
112
113	elmex	1.3	sub retrieve_roster {
114	elmex	1.7	my ($self, $init) = @_;
115	elmex	1.4
116	elmex	1.3	$self->send_iq (get => sub {
117			my ($w) = @_;
118			$w->addPrefix (xmpp_ns ('roster'), '');
119			$w->emptyTag ([xmpp_ns ('roster'), 'query']);
120	elmex	1.4
121	elmex	1.3	}, sub {
122			my ($node, $errnode, $errar) = @_;
123			if ($node) {
124			$self->store_roster ($node);
125			} else {
126	elmex	1.4	$self->event (roster_error => $errnode, $errar); # TODO: make error obj
127	elmex	1.3	}
128	elmex	1.7
129			$self->send_presence if $init;
130	elmex	1.3	});
131			}
132
133			sub store_roster {
134			my ($self, $node) = @_;
135
136			my ($query) = $node->find_all ([qw/roster query/]);
137			return unless $query;
138
139	elmex	1.8	my @upd;
140
141	elmex	1.3	for my $item ($query->find_all ([qw/roster item/])) {
142			my ($jid, $name, $subscription) =
143			($item->attr ('jid'), $item->attr ('name'), $item->attr ('subscription'));
144			my @groups;
145			push @groups, $_->text for $item->find_all ([qw/roster group/]);
146
147	elmex	1.8	push @upd,
148			$self->{roster}->set_contact ($jid,
149			name => $name,
150			subscription => $subscription,
151			groups => [ @groups ]
152			);
153	elmex	1.3	}
154
155	elmex	1.8	$self->event (roster_update => $self->{roster}, \@upd);
156	elmex	1.5	}
157
158			sub get_roster {
159			my ($self) = @_;
160			$self->{roster}
161			}
162
163			sub handle_iq_set {
164			my ($self, $node, $rhandled) = @_;
165
166			if ($node->find_all ([qw/roster query/])) {
167			$self->store_roster ($node);
168			$self->reply_iq_result ($node, sub {});
169			}
170	elmex	1.3	}
171
172	elmex	1.2	sub handle_presence {
173	elmex	1.5	my ($self, $node) = @_;
174
175			my $type = $node->attr ('type');
176			my ($show) = $node->find_all ([qw/client show/]);
177			my ($priority) = $node->find_all ([qw/client priority/]);
178
179			my $jid = $node->attr ('from');
180
181	elmex	1.6	my %stati;
182			$stati{$_->attr ('lang') \|\| ''} = $_->text
183	elmex	1.5	for $node->find_all ([qw/client status/]);
184
185	elmex	1.8	my $old =
186			$self->{roster}->set_presence ($jid,
187			show => $show ? $show->text : undef,
188			priority => $priority ? $priority->text : undef,
189			type => $type,
190			status => \%stati,
191			);
192
193			my $new = $self->{roster}->get_contact ($jid)->get_presence ($jid);
194	elmex	1.2
195	elmex	1.8	$self->event (presence_update => $self->{roster}, $self->{roster}->get_contact ($jid), $old, $new)
196	elmex	1.2	}
197
198			sub handle_message {
199	elmex	1.6	my ($self, $node) = @_;
200
201			my $from = $node->attr ('from');
202			my $to = $node->attr ('to');
203			my $type = $node->attr ('type');
204			my ($thread) = $node->find_all ([qw/client thread/]);
205
206			my %bodies;
207			my %subjects;
208
209			$bodies{$_->attr ('lang') \|\| ''} = $_->text
210			for $node->find_all ([qw/client body/]);
211			$subjects{$_->attr ('lang') \|\| ''} = $_->text
212			for $node->find_all ([qw/client subject/]);
213
214			my $msg =
215			Net::XMPP2::IM::Message->new (
216			connection => $self,
217			from => $from,
218			to => $to,
219			type => $type,
220			bodies => \%bodies,
221			subjects => \%subjects,
222			thread => $thread
223			);
224
225			$self->event (message => $msg);
226	elmex	1.2	}
227
228	elmex	1.5	sub handle_disconnect {
229			my ($self) = @_;
230			delete $self->{roster};
231			}
232
233	elmex	1.1	=head1 EVENTS
234
235			These additional events can be registered on with C<reg_cb>:
236
237			=over 4
238
239			=item session_ready
240
241	elmex	1.2	This event is generated when the session has been fully established and
242			can be used to send around messages and other stuff.
243
244			=item session_error => $erriq, $errarr
245
246			If an error happened during establishment of the session this
247			event will be generated. C<$erriq> is the L<Net::XMPP2::Node> object
248			of the error iq tag and C<$errar> is an error array as described in
249			L<Net::XMPP2::Connection::send_iq> for error responses for iq requests.
250	elmex	1.1
251	elmex	1.8	=item roster_update => $roster, $contacts
252
253			This event is emitted when a roster update has been received.
254			C<$roster> is the L<Net::XMPP2::IM::Roster> object you get by
255			calling C<get_roster>.
256			C<$contacts> is an array reference of L<Net::XMPP2::IM::Contact> objects
257			which have changed.
258
259			=item presence_update => $roster, $contact, $old_presence, $new_presence
260
261			This event is emitted when the presence of a contact has changed.
262			C<$roster> is the L<Net::XMPP2::IM::Roster> object you get by
263			calling C<get_roster>.
264			C<$contact> is the L<Net::XMPP2::IM::Contact> object which presence status
265			has changed.
266			C<$old_presence> is a L<Net::XMPP2::IM::Presence> object which represents the
267			presence prior to the change.
268			C<$new_presence> is a L<Net::XMPP2::IM::Presence> object which represents the
269			presence after to the change.
270
271			=item message => $msg
272
273			This event is emitted when a message was received.
274			C<$msg> is a L<Net::XMPP2::IM::Message> object.
275
276	elmex	1.1	=back
277
278			=head1 AUTHOR
279
280			Robin Redeker, C<< <elmex at ta-sa.org> >>
281
282			=head1 COPYRIGHT & LICENSE
283
284			Copyright 2007 Robin Redeker, all rights reserved.
285
286			This program is free software; you can redistribute it and/or modify it
287			under the same terms as Perl itself.
288
289			=cut
290
291			1; # End of Net::XMPP2