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

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->{session_active} = 1;
         $self->send_presence ();
         $self->event ('session_ready');
      }
   });
   $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->{session_active} = 1;
         $self->send_presence;
         $self->retrieve_roster;
         $self->event ('session_ready');
      } else {
         $self->event (session_error => $errnode, $errar); # TODO: make error obj
      }
   });
}

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

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

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

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

   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/]);

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

   $self->event (roster_update => $self->{roster});
}

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/]);

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

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

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.

=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


1; # End of Net::XMPP2
Revision:	1.6
Committed:	Fri Feb 9 16:46:40 2007 UTC (19 years, 8 months ago) by elmex
Branch:	MAIN
Changes since 1.5:	+31 -4 lines
Log Message:	implemented roster and message sending mostly. along with presence handling.
#	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			sub new {
34			my $this = shift;
35			my $class = ref($this) \|\| $this;
36			my $self = $class->SUPER::new (@_);
37	elmex	1.2
38			$self->{ext} = {}; # reserved for extensions
39	elmex	1.5	$self->{roster} = Net::XMPP2::IM::Roster->new (connection => $self);
40	elmex	1.2
41	elmex	1.5	$self->reg_cb (message_xml =>
42			sub { shift @_; $self->handle_message (@_); 1 });
43			$self->reg_cb (presence_xml =>
44			sub { shift @_; $self->handle_presence (@_); 1 });
45			$self->reg_cb (iq_set_request_xml =>
46			sub { shift @_; $self->handle_iq_set (@_); 1 });
47			$self->reg_cb (disconnect =>
48			sub { shift @_; $self->handle_disconnect (@_); 1 });
49	elmex	1.2
50	elmex	1.1	$self->reg_cb (stream_ready => sub {
51			my ($jid) = @_;
52	elmex	1.2	if ($self->features ()->find_all ([qw/session session/])) {
53			$self->send_session_iq;
54			} else {
55			$self->{session_active} = 1;
56			$self->send_presence ();
57	elmex	1.1	$self->event ('session_ready');
58	elmex	1.2	}
59	elmex	1.1	});
60			$self
61			}
62
63	elmex	1.2	sub send_session_iq {
64			my ($self) = @_;
65
66			$self->send_iq (set => sub {
67			my ($w) = @_;
68			$w->addPrefix (xmpp_ns ('session'), '');
69			$w->emptyTag ([xmpp_ns ('session'), 'session']);
70
71			}, sub {
72			my ($node, $errnode, $errar) = @_;
73			if ($node) {
74			$self->{session_active} = 1;
75			$self->send_presence;
76	elmex	1.3	$self->retrieve_roster;
77	elmex	1.2	$self->event ('session_ready');
78			} else {
79	elmex	1.4	$self->event (session_error => $errnode, $errar); # TODO: make error obj
80	elmex	1.2	}
81			});
82			}
83
84	elmex	1.3	sub retrieve_roster {
85			my ($self) = @_;
86	elmex	1.4
87	elmex	1.3	$self->send_iq (get => sub {
88			my ($w) = @_;
89			$w->addPrefix (xmpp_ns ('roster'), '');
90			$w->emptyTag ([xmpp_ns ('roster'), 'query']);
91	elmex	1.4
92	elmex	1.3	}, sub {
93			my ($node, $errnode, $errar) = @_;
94			if ($node) {
95			$self->store_roster ($node);
96			} else {
97	elmex	1.4	$self->event (roster_error => $errnode, $errar); # TODO: make error obj
98	elmex	1.3	}
99			});
100			}
101
102			sub store_roster {
103			my ($self, $node) = @_;
104
105			my ($query) = $node->find_all ([qw/roster query/]);
106			return unless $query;
107
108			for my $item ($query->find_all ([qw/roster item/])) {
109			my ($jid, $name, $subscription) =
110			($item->attr ('jid'), $item->attr ('name'), $item->attr ('subscription'));
111			my @groups;
112			push @groups, $_->text for $item->find_all ([qw/roster group/]);
113
114	elmex	1.5	$self->{roster}->set_contact ($jid,
115	elmex	1.3	name => $name,
116			subscription => $subscription,
117			groups => [ @groups ]
118	elmex	1.5	);
119	elmex	1.3	}
120
121	elmex	1.5	$self->event (roster_update => $self->{roster});
122			}
123
124			sub get_roster {
125			my ($self) = @_;
126			$self->{roster}
127			}
128
129			sub handle_iq_set {
130			my ($self, $node, $rhandled) = @_;
131
132			if ($node->find_all ([qw/roster query/])) {
133			$self->store_roster ($node);
134			$self->reply_iq_result ($node, sub {});
135			}
136	elmex	1.3	}
137
138	elmex	1.2	sub handle_presence {
139	elmex	1.5	my ($self, $node) = @_;
140
141			my $type = $node->attr ('type');
142			my ($show) = $node->find_all ([qw/client show/]);
143			my ($priority) = $node->find_all ([qw/client priority/]);
144
145			my $jid = $node->attr ('from');
146
147	elmex	1.6	my %stati;
148			$stati{$_->attr ('lang') \|\| ''} = $_->text
149	elmex	1.5	for $node->find_all ([qw/client status/]);
150
151			$self->{roster}->set_presence ($jid,
152			show => $show ? $show->text : undef,
153			priority => $priority ? $priority->text : undef,
154			type => $type,
155	elmex	1.6	status => \%stati,
156	elmex	1.5	);
157	elmex	1.2
158	elmex	1.5	$self->event (presence_update => $self->{roster}, $self->{roster}->get_contact ($jid))
159	elmex	1.2	}
160
161			sub handle_message {
162	elmex	1.6	my ($self, $node) = @_;
163
164			my $from = $node->attr ('from');
165			my $to = $node->attr ('to');
166			my $type = $node->attr ('type');
167			my ($thread) = $node->find_all ([qw/client thread/]);
168
169			my %bodies;
170			my %subjects;
171
172			$bodies{$_->attr ('lang') \|\| ''} = $_->text
173			for $node->find_all ([qw/client body/]);
174			$subjects{$_->attr ('lang') \|\| ''} = $_->text
175			for $node->find_all ([qw/client subject/]);
176
177			my $msg =
178			Net::XMPP2::IM::Message->new (
179			connection => $self,
180			from => $from,
181			to => $to,
182			type => $type,
183			bodies => \%bodies,
184			subjects => \%subjects,
185			thread => $thread
186			);
187
188			$self->event (message => $msg);
189	elmex	1.2	}
190
191	elmex	1.5	sub handle_disconnect {
192			my ($self) = @_;
193			delete $self->{roster};
194			}
195
196	elmex	1.1	=head1 EVENTS
197
198			These additional events can be registered on with C<reg_cb>:
199
200			=over 4
201
202			=item session_ready
203
204	elmex	1.2	This event is generated when the session has been fully established and
205			can be used to send around messages and other stuff.
206
207			=item session_error => $erriq, $errarr
208
209			If an error happened during establishment of the session this
210			event will be generated. C<$erriq> is the L<Net::XMPP2::Node> object
211			of the error iq tag and C<$errar> is an error array as described in
212			L<Net::XMPP2::Connection::send_iq> for error responses for iq requests.
213	elmex	1.1
214			=back
215
216			=head1 AUTHOR
217
218			Robin Redeker, C<< <elmex at ta-sa.org> >>
219
220			=head1 BUGS
221
222			Please report any bugs or feature requests to
223			C<bug-net-xmpp2 at rt.cpan.org>, or through the web interface at
224			L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-XMPP2>.
225			I will be notified, and then you'll automatically be notified of progress on
226			your bug as I make changes.
227
228			=head1 SUPPORT
229
230			You can find documentation for this module with the perldoc command.
231
232			perldoc Net::XMPP2
233
234			You can also look for information at:
235
236			=over 4
237
238			=item * AnnoCPAN: Annotated CPAN documentation
239
240			L<http://annocpan.org/dist/Net-XMPP2>
241
242			=item * CPAN Ratings
243
244			L<http://cpanratings.perl.org/d/Net-XMPP2>
245
246			=item * RT: CPAN's request tracker
247
248			L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-XMPP2>
249
250			=item * Search CPAN
251
252			L<http://search.cpan.org/dist/Net-XMPP2>
253
254			=back
255
256			=head1 ACKNOWLEDGEMENTS
257
258			=head1 COPYRIGHT & LICENSE
259
260			Copyright 2007 Robin Redeker, all rights reserved.
261
262			This program is free software; you can redistribute it and/or modify it
263			under the same terms as Perl itself.
264
265			=cut
266
267
268
269			1; # End of Net::XMPP2