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 - "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

=over 4

=item B<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.

=item initial_presence => $priority

This sets whether the initial presence should be sent. C<$priority>
should be the priority of the initial presence. The default value
for the initial presence C<$priority> is 10.

If you pass a undefined value as C<$priority> no initial presence will
be sent!

=back

=cut

sub new {
   my $this = shift;
   my $class = ref($this) || $this;

   my %args = @_;

   unless (exists $args{initial_presence}) {
      $args{initial_presence} = 10;
   }

   my $self = $class->SUPER::new (%args);

   $self->{roster} = Net::XMPP2::IM::Roster->new (connection => $self);

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

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

   my $proxy_cb = sub {
      my ($self, $er) = @_;
      $self->event (error => $er);
   };

   $self->reg_cb (
      session_error  => $proxy_cb,
      roster_error   => $proxy_cb,
      presence_error => $proxy_cb,
      message_error  => $proxy_cb,
   );

   $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, $error) = @_;
      if ($node) {
         $self->init_connection;
      } else {
         $self->event (session_error => $error);
      }
   });
}

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

   } else {
      $self->retrieve_roster (sub {
         $self->initial_presence;
         $self->{session_active} = 1;
         $self->event ('session_ready');
      });
   }
}

sub initial_presence {
   my ($self) = @_;
   if (defined $self->{initial_presence}) {
      $self->send_presence (undef, undef, priority => $self->{initial_presence});
   }
   # else do nothing
}

=item B<retrieve_roster ($cb)>

This method initiates a roster request. If you set C<dont_retrieve_roster>
when creating this connection no roster was retrieved.
You can do that with this method. The coderef in C<$cb> will be
called after the roster was retrieved.

The first argument of the callback in C<$cb> will be the roster
and the second will be a L<Net::XMPP2::Error::IQ> object when
an error occured while retrieving the roster.

=cut

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

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

   }, sub {
      my ($node, $error) = @_;
      if ($node) {
         $self->{roster}->set_retrieved;
         $self->store_roster ($node);
      } else {
         $self->event (roster_error => $error);
      }

      $cb->($self, $self->{roster}, $error) if $cb
   });
}

sub store_roster {
   my ($self, $node) = @_;
   my @upd = $self->{roster}->update ($node);
   $self->event (roster_update => $self->{roster}, \@upd);
}

=item B<get_roster>

Returns the roster object of type L<Net::XMPP2::IM::Roster>.

=cut

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);
      $$rhandled = 1
   }
}

sub handle_presence {
   my ($self, $node) = @_;
   if ($node->attr ('type') eq 'error') {
      my $error = Net::XMPP2::Error::Presence->new (node => $node);
      $self->event (presence_error => $error);
      return if $error->type ne 'continue';
   }

   my ($contact, $old, $new) = $self->{roster}->update_presence ($node);
   $self->event (presence_update => $self->{roster}, $contact, $old, $new)
}

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

   if ($node->attr ('type') eq 'error') {
      my $error = Net::XMPP2::Error::Message->new (node => $node);
      $self->event (message_error => $error);
      return if $error->type ne 'continue';
   }

   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};
}

=back

=head1 EVENTS

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

In the following events C<$roster> is the L<Net::XMPP2::IM::Roster>
object you get by calling C<get_roster>.

=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 => $error

If an error happened during establishment of the session this
event will be generated. C<$error> will be an L<Net::XMPP2::Error::IQ>
error object.

=item roster_update => $roster, $contacts

This event is emitted when a roster update has been received.
C<$contacts> is an array reference of L<Net::XMPP2::IM::Contact> objects
which have changed. If a contact was removed it will return 'remove'
when you call the C<subscription> method on it.

The first time this event is sent is when the roster was received
for the first time.

=item roster_error => $error

If an error happened during retrival of the roster this event will
be generated.
C<$error> will be an L<Net::XMPP2::Error::IQ> error object.

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

This event is emitted when the presence of a contact has changed.
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 presence_error => $error

This event is emitted when a presence stanza error was received.
C<$error> will be an L<Net::XMPP2::Error::Presence> error object.

=item message => $msg

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

=item message_error => $error

This event is emitted when a message stanza error was received.
C<$error> will be an L<Net::XMPP2::Error::Message> error object.

=item contact_request_subscribe => $roster, $contact

This event is generated when the C<$contact> wants to subscribe
to your presence.

If any of the event callbacks for this event return a true value then the
subscription request is accepted and a subscribed presence is sent.  If all
callbacks return a false value the subscription request is cancelled.  If none
of the callbacks return anything (all return an empty list) nothing of the
former two things are done.

If you want to accept or decline the request later, call
C<send_subscribed> method of L<Net::XMPP2::IM::Contact> or
C<send_unsubscribed> method of L<Net::XMPP2::IM::Contact> on C<$contact>.

=item contact_subscribed => $roster, $contact

This event is generated when C<$contact> subscribed to your presence successfully.

=item contact_did_unsubscribe => $roster, $contact, $rdoit

This event is generated when C<$contact> unsubscribes from your presence.

Returning a true value from any event callback will also unsubscribe you from
the presence of the contact.

If you want to unsubscribe later from him call the C<send_unsubscribed> method
of L<Net::XMPP2::IM::Contact> on C<$contact>.

=item contact_unsubscribed => $roster, $contact

This event is generated when C<$contact> unsubscribed you from his presence.

=back

=head1 AUTHOR

Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.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.21
Committed:	Tue Jul 24 13:35:22 2007 UTC (19 years, 3 months ago) by elmex
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.20:	+11 -6 lines
Log Message:	changed subscription semantics
#	Content
1	package Net::XMPP2::IM::Connection;
2	use strict;
3	use Net::XMPP2::Connection;
4	use Net::XMPP2::Namespaces qw/xmpp_ns/;
5	use Net::XMPP2::IM::Roster;
6	use Net::XMPP2::IM::Message;
7	our @ISA = qw/Net::XMPP2::Connection/;
8
9	=head1 NAME
10
11	Net::XMPP2::IM::Connection - "XML" stream that implements the XMPP RFC 3921.
12
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	=over 4
32
33	=item B<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	=item initial_presence => $priority
53
54	This sets whether the initial presence should be sent. C<$priority>
55	should be the priority of the initial presence. The default value
56	for the initial presence C<$priority> is 10.
57
58	If you pass a undefined value as C<$priority> no initial presence will
59	be sent!
60
61	=back
62
63	=cut
64
65	sub new {
66	my $this = shift;
67	my $class = ref($this) \|\| $this;
68
69	my %args = @_;
70
71	unless (exists $args{initial_presence}) {
72	$args{initial_presence} = 10;
73	}
74
75	my $self = $class->SUPER::new (%args);
76
77	$self->{roster} = Net::XMPP2::IM::Roster->new (connection => $self);
78
79	$self->reg_cb (message_xml =>
80	sub { shift @_; $self->handle_message (@_); });
81	$self->reg_cb (presence_xml =>
82	sub { shift @_; $self->handle_presence (@_); });
83	$self->reg_cb (iq_set_request_xml =>
84	sub { shift @_; $self->handle_iq_set (@_); });
85	$self->reg_cb (disconnect =>
86	sub { shift @_; $self->handle_disconnect (@_); });
87
88	$self->reg_cb (stream_ready => sub {
89	my ($jid) = @_;
90	if ($self->features ()->find_all ([qw/session session/])) {
91	$self->send_session_iq;
92	} else {
93	$self->init_connection;
94	}
95	});
96
97	my $proxy_cb = sub {
98	my ($self, $er) = @_;
99	$self->event (error => $er);
100	};
101
102	$self->reg_cb (
103	session_error => $proxy_cb,
104	roster_error => $proxy_cb,
105	presence_error => $proxy_cb,
106	message_error => $proxy_cb,
107	);
108
109	$self
110	}
111
112	sub send_session_iq {
113	my ($self) = @_;
114
115	$self->send_iq (set => sub {
116	my ($w) = @_;
117	$w->addPrefix (xmpp_ns ('session'), '');
118	$w->emptyTag ([xmpp_ns ('session'), 'session']);
119
120	}, sub {
121	my ($node, $error) = @_;
122	if ($node) {
123	$self->init_connection;
124	} else {
125	$self->event (session_error => $error);
126	}
127	});
128	}
129
130	sub init_connection {
131	my ($self) = @_;
132	if ($self->{dont_retrieve_roster}) {
133	$self->initial_presence;
134	$self->{session_active} = 1;
135	$self->event ('session_ready');
136
137	} else {
138	$self->retrieve_roster (sub {
139	$self->initial_presence;
140	$self->{session_active} = 1;
141	$self->event ('session_ready');
142	});
143	}
144	}
145
146	sub initial_presence {
147	my ($self) = @_;
148	if (defined $self->{initial_presence}) {
149	$self->send_presence (undef, undef, priority => $self->{initial_presence});
150	}
151	# else do nothing
152	}
153
154	=item B<retrieve_roster ($cb)>
155
156	This method initiates a roster request. If you set C<dont_retrieve_roster>
157	when creating this connection no roster was retrieved.
158	You can do that with this method. The coderef in C<$cb> will be
159	called after the roster was retrieved.
160
161	The first argument of the callback in C<$cb> will be the roster
162	and the second will be a L<Net::XMPP2::Error::IQ> object when
163	an error occured while retrieving the roster.
164
165	=cut
166
167	sub retrieve_roster {
168	my ($self, $cb) = @_;
169
170	$self->send_iq (get => sub {
171	my ($w) = @_;
172	$w->addPrefix (xmpp_ns ('roster'), '');
173	$w->emptyTag ([xmpp_ns ('roster'), 'query']);
174
175	}, sub {
176	my ($node, $error) = @_;
177	if ($node) {
178	$self->{roster}->set_retrieved;
179	$self->store_roster ($node);
180	} else {
181	$self->event (roster_error => $error);
182	}
183
184	$cb->($self, $self->{roster}, $error) if $cb
185	});
186	}
187
188	sub store_roster {
189	my ($self, $node) = @_;
190	my @upd = $self->{roster}->update ($node);
191	$self->event (roster_update => $self->{roster}, \@upd);
192	}
193
194	=item B<get_roster>
195
196	Returns the roster object of type L<Net::XMPP2::IM::Roster>.
197
198	=cut
199
200	sub get_roster {
201	my ($self) = @_;
202	$self->{roster}
203	}
204
205	sub handle_iq_set {
206	my ($self, $node, $rhandled) = @_;
207
208	if ($node->find_all ([qw/roster query/])) {
209	$self->store_roster ($node);
210	$self->reply_iq_result ($node);
211	$$rhandled = 1
212	}
213	}
214
215	sub handle_presence {
216	my ($self, $node) = @_;
217	if ($node->attr ('type') eq 'error') {
218	my $error = Net::XMPP2::Error::Presence->new (node => $node);
219	$self->event (presence_error => $error);
220	return if $error->type ne 'continue';
221	}
222
223	my ($contact, $old, $new) = $self->{roster}->update_presence ($node);
224	$self->event (presence_update => $self->{roster}, $contact, $old, $new)
225	}
226
227	sub handle_message {
228	my ($self, $node) = @_;
229
230	if ($node->attr ('type') eq 'error') {
231	my $error = Net::XMPP2::Error::Message->new (node => $node);
232	$self->event (message_error => $error);
233	return if $error->type ne 'continue';
234	}
235
236	my $from = $node->attr ('from');
237	my $to = $node->attr ('to');
238	my $type = $node->attr ('type');
239	my ($thread) = $node->find_all ([qw/client thread/]);
240
241	my %bodies;
242	my %subjects;
243
244	$bodies{$_->attr ('lang') \|\| ''} = $_->text
245	for $node->find_all ([qw/client body/]);
246	$subjects{$_->attr ('lang') \|\| ''} = $_->text
247	for $node->find_all ([qw/client subject/]);
248
249	my $msg =
250	Net::XMPP2::IM::Message->new (
251	connection => $self,
252	from => $from,
253	to => $to,
254	type => $type,
255	bodies => \%bodies,
256	subjects => \%subjects,
257	thread => $thread
258	);
259
260	$self->event (message => $msg);
261	}
262
263	sub handle_disconnect {
264	my ($self) = @_;
265	delete $self->{roster};
266	}
267
268	=back
269
270	=head1 EVENTS
271
272	These additional events can be registered on with C<reg_cb>:
273
274	In the following events C<$roster> is the L<Net::XMPP2::IM::Roster>
275	object you get by calling C<get_roster>.
276
277	=over 4
278
279	=item session_ready
280
281	This event is generated when the session has been fully established and
282	can be used to send around messages and other stuff.
283
284	=item session_error => $error
285
286	If an error happened during establishment of the session this
287	event will be generated. C<$error> will be an L<Net::XMPP2::Error::IQ>
288	error object.
289
290	=item roster_update => $roster, $contacts
291
292	This event is emitted when a roster update has been received.
293	C<$contacts> is an array reference of L<Net::XMPP2::IM::Contact> objects
294	which have changed. If a contact was removed it will return 'remove'
295	when you call the C<subscription> method on it.
296
297	The first time this event is sent is when the roster was received
298	for the first time.
299
300	=item roster_error => $error
301
302	If an error happened during retrival of the roster this event will
303	be generated.
304	C<$error> will be an L<Net::XMPP2::Error::IQ> error object.
305
306	=item presence_update => $roster, $contact, $old_presence, $new_presence
307
308	This event is emitted when the presence of a contact has changed.
309	C<$contact> is the L<Net::XMPP2::IM::Contact> object which presence status
310	has changed.
311	C<$old_presence> is a L<Net::XMPP2::IM::Presence> object which represents the
312	presence prior to the change.
313	C<$new_presence> is a L<Net::XMPP2::IM::Presence> object which represents the
314	presence after to the change.
315
316	=item presence_error => $error
317
318	This event is emitted when a presence stanza error was received.
319	C<$error> will be an L<Net::XMPP2::Error::Presence> error object.
320
321	=item message => $msg
322
323	This event is emitted when a message was received.
324	C<$msg> is a L<Net::XMPP2::IM::Message> object.
325
326	=item message_error => $error
327
328	This event is emitted when a message stanza error was received.
329	C<$error> will be an L<Net::XMPP2::Error::Message> error object.
330
331	=item contact_request_subscribe => $roster, $contact
332
333	This event is generated when the C<$contact> wants to subscribe
334	to your presence.
335
336	If any of the event callbacks for this event return a true value then the
337	subscription request is accepted and a subscribed presence is sent. If all
338	callbacks return a false value the subscription request is cancelled. If none
339	of the callbacks return anything (all return an empty list) nothing of the
340	former two things are done.
341
342	If you want to accept or decline the request later, call
343	C<send_subscribed> method of L<Net::XMPP2::IM::Contact> or
344	C<send_unsubscribed> method of L<Net::XMPP2::IM::Contact> on C<$contact>.
345
346	=item contact_subscribed => $roster, $contact
347
348	This event is generated when C<$contact> subscribed to your presence successfully.
349
350	=item contact_did_unsubscribe => $roster, $contact, $rdoit
351
352	This event is generated when C<$contact> unsubscribes from your presence.
353
354	Returning a true value from any event callback will also unsubscribe you from
355	the presence of the contact.
356
357	If you want to unsubscribe later from him call the C<send_unsubscribed> method
358	of L<Net::XMPP2::IM::Contact> on C<$contact>.
359
360	=item contact_unsubscribed => $roster, $contact
361
362	This event is generated when C<$contact> unsubscribed you from his presence.
363
364	=back
365
366	=head1 AUTHOR
367
368	Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
369
370	=head1 COPYRIGHT & LICENSE
371
372	Copyright 2007 Robin Redeker, all rights reserved.
373
374	This program is free software; you can redistribute it and/or modify it
375	under the same terms as Perl itself.
376
377	=cut
378
379	1; # End of Net::XMPP2