XMPP2/Ext/Disco.pm

package Net::XMPP2::Ext::Disco;
use Net::XMPP2::Namespaces qw/xmpp_ns/;
use Net::XMPP2::Ext::Disco::Items;
use Net::XMPP2::Ext::Disco::Info;
use Net::XMPP2::Ext;

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

=head1 NAME

Net::XMPP2::Ext::Disco - Service discovery manager class for XEP-0030

=head1 SYNOPSIS

   package foo;
   use Net::XMPP2::Ext::Disco;

   my $con = Net::XMPP2::IM::Connection->new (...);
   ...
   my $disco = Net::XMPP2::Ext::Disco->new (connection => $con);

   $disco->request_items ('romeo@montague.net',
      node => 'http://jabber.org/protocol/tune',
      cb   => sub {
         my ($disco, $response, $error) = @_;
         if ($error) { print "ERROR".$error->string."\n" }
         else {
            ... do something with the $response ...
         }
      }
   );

=head1 DESCRIPTION

This module represents a service discovery manager class.
You make instances of this class and get a handle to send
discovery requests like described in XEP-0030.

It also allows you to setup a disco-info/items tree
that others can walk and also lets you publish disco information.

This class is derived from L<Net::XMPP2::Ext> and can be added as extension to
objects that implement the L<Net::XMPP2::Extendable> interface or derive from
it.

=head1 METHODS

=over 4

=item B<new (%args)>

Creates a new disco handle.

=cut

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

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

   $self->set_identity (client => console => 'Net::XMPP2');

   $self->reg_cb (
      iq_get_request_xml => sub {
         my ($self, $con, $node, $handled_ref) = @_;
         return 1 if $$handled_ref;

         if ($self->handle_disco_query ($con, $node)) {
            $$handled_ref = 1;
         }

         1
      }
   );
}

=item B<set_identity ($category, $type, $name)>

This sets the identity of the top info node.
The default is: C<$category = "client">, C<$type = "console">
and C<$name = "Net::XMPP2">.

C<$name> is optional and can be undef.

For a list of valid identites look at:

   http://www.xmpp.org/registrar/disco-categories.html

Valid identity types for C<$category = "client"> may be:

   bot
   console
   handheld
   pc
   phone
   web

=cut

sub set_identity {
   my ($self, $category, $type, $name) = @_;
   $self->{iden}->{cat}  = $category;
   $self->{iden}->{type} = $type;
   $self->{iden}->{name} = $name;
}


=item B<enable_feature ($uri)>

This method enables the feature C<$uri>, where C<$uri>
should be one of the values from the B<Name> column on:

   http://www.xmpp.org/registrar/disco-features.html

These features are enabled by default:

   http://jabber.org/protocol/disco#info
   http://jabber.org/protocol/disco#items

=cut

sub enable_feature {
   my ($self, $feature) = @_;
   $self->{feat}->{$feature} = 1
}

=item B<disable_feature ($uri)>

This method enables the feature C<$uri>, where C<$uri>
should be one of the values from the B<Name> column on:

   http://www.xmpp.org/registrar/disco-features.html

These features are enabled by default:

   http://jabber.org/protocol/disco#info
   http://jabber.org/protocol/disco#items

=cut

sub disable_feature {
   my ($self, $feature) = @_;
   delete $self->{feat}->{$feature}
}

sub write_feature {
   my ($self, $w, $var) = @_;

   $w->emptyTag ([xmpp_ns ('disco_info'), 'feature'], var => $var);
}

sub write_identity {
   my ($self, $w, $cat, $type, $name) = @_;

   $w->emptyTag ([xmpp_ns ('disco_info'), 'identity'],
      category => $cat,
      type     => $type,
      (defined $name ? (name => $name) : ())
   );
}

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

   if ($node->find_all ([qw/disco_info query/])) {
      $con->reply_iq_result (
         $node, sub {
            my ($w) = @_;

            if ($node->attr ('node')) {
               $w->addPrefix (xmpp_ns ('disco_info'), '');
               $w->emptyTag ([xmpp_ns ('disco_info'), 'query']);

            } else {
               $w->addPrefix (xmpp_ns ('disco_info'), '');
               $w->startTag ([xmpp_ns ('disco_info'), 'query']);
                  $self->write_identity ($w,
                     $self->{iden}->{cat},
                     $self->{iden}->{type},
                     $self->{iden}->{name},
                  );
                  $self->write_feature ($w, 'http://jabber.org/protocol/disco#info');
                  $self->write_feature ($w, 'http://jabber.org/protocol/disco#items');
               $w->endTag;
            }
         },
         to => $node->attr ('from')
      );

      return 1

   } elsif ($node->find_all ([qw/disco_items query/])) {
      $con->reply_iq_result (
         $node, sub {
            my ($w) = @_;

            if ($node->attr ('node')) {
               $w->addPrefix (xmpp_ns ('disco_items'), '');
               $w->emptyTag ([xmpp_ns ('disco_items'), 'query']);

            } else {
               $w->addPrefix (xmpp_ns ('disco_items'), '');
               $w->emptyTag ([xmpp_ns ('disco_items'), 'query']);
            }
         },
         to => $node->attr ('from')
      );

      return 1
   }

   0
}

sub DESTROY {
   my ($self) = @_;
   $self->{connection}->unreg_cb ($self->{cb_id})
}


=item B<request_items ($con, $dest, $node, $cb)>

This method does send a items request to the JID entity C<$from>.
C<$node> is the optional node to send the request to, which can be
undef.
C<$con> must be an instance of L<Net::XMPP2::Connection> or a subclass of it.
The callback C<$cb> will be called when the request returns with 3 arguments:
the disco handle, an L<Net::XMPP2::Ext::Disco::Items> object (or undef)
and an L<Net::XMPP2::Error::IQ> object when an error occured and no items
were received.

   $disco->request_items ($con, 'a@b.com', undef, sub {
      my ($disco, $items, $error) = @_;
      die $error->string if $error;

      # do something with the items here ;_)
   });

=cut

sub request_items {
   my ($self, $con, $dest, $node, $cb) = @_;

   $con->send_iq (
      get => sub {
         my ($w) = @_;
         $w->addPrefix (xmpp_ns ('disco_items'), '');
         $w->emptyTag ([xmpp_ns ('disco_items'), 'query'],
            (defined $node ? (node => $node) : ())
         );
      },
      sub {
         my ($xmlnode, $error) = @_;
         my $items;

         if ($xmlnode) {
            my (@query) = $xmlnode->find_all ([qw/disco_items query/]);
            $items = Net::XMPP2::Ext::Disco::Items->new (
               jid     => $dest,
               node    => $node,
               xmlnode => $query[0]
            )
         }

         $cb->($self, $items, $error)
      },
      to => $dest
   );
}

=item B<request_info ($con, $dest, $node, $cb)>

This method does send a info request to the JID entity C<$from>.
C<$node> is the optional node to send the request to, which can be
undef.
C<$con> must be an instance of L<Net::XMPP2::Connection> or a subclass of it.
The callback C<$cb> will be called when the request returns with 3 arguments:
the disco handle, an L<Net::XMPP2::Ext::Disco::Info> object (or undef)
and an L<Net::XMPP2::Error::IQ> object when an error occured and no items
were received.

   $disco->request_info ('a@b.com', undef, sub {
      my ($disco, $info, $error) = @_;
      die $error->string if $error;

      # do something with info here ;_)
   });

=cut

sub request_info {
   my ($self, $con, $dest, $node, $cb) = @_;

   $con->send_iq (
      get => sub {
         my ($w) = @_;
         $w->addPrefix (xmpp_ns ('disco_info'), '');
         $w->emptyTag ([xmpp_ns ('disco_info'), 'query'],
            (defined $node ? (node => $node) : ())
         );
      },
      sub {
         my ($xmlnode, $error) = @_;
         my $info;

         if ($xmlnode) {
            my (@query) = $xmlnode->find_all ([qw/disco_info query/]);
            $info = Net::XMPP2::Ext::Disco::Info->new (
               jid     => $dest,
               node    => $node,
               xmlnode => $query[0]
            )
         }

         $cb->($self, $info, $error)
      },
      to => $dest
   );
}

=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;
Revision:	1.6
Committed:	Sat Jul 7 12:39:45 2007 UTC (19 years, 3 months ago) by elmex
Branch:	MAIN
Changes since 1.5:	+34 -35 lines
Log Message:	fixed some bugs, redesigned disco mechanism, probably added some bugs, added samples/disco_test example.
#	User	Rev	Content
1	elmex	1.3	package Net::XMPP2::Ext::Disco;
2	elmex	1.1	use Net::XMPP2::Namespaces qw/xmpp_ns/;
3	elmex	1.3	use Net::XMPP2::Ext::Disco::Items;
4			use Net::XMPP2::Ext::Disco::Info;
5	elmex	1.6	use Net::XMPP2::Ext;
6
7			our @ISA = qw/Net::XMPP2::Ext/;
8	elmex	1.1
9			=head1 NAME
10
11	elmex	1.5	Net::XMPP2::Ext::Disco - Service discovery manager class for XEP-0030
12	elmex	1.1
13			=head1 SYNOPSIS
14
15			package foo;
16	elmex	1.3	use Net::XMPP2::Ext::Disco;
17	elmex	1.1
18			my $con = Net::XMPP2::IM::Connection->new (...);
19			...
20	elmex	1.3	my $disco = Net::XMPP2::Ext::Disco->new (connection => $con);
21	elmex	1.1
22			$disco->request_items ('romeo@montague.net',
23			node => 'http://jabber.org/protocol/tune',
24			cb => sub {
25			my ($disco, $response, $error) = @_;
26			if ($error) { print "ERROR".$error->string."\n" }
27			else {
28			... do something with the $response ...
29			}
30			}
31			);
32
33			=head1 DESCRIPTION
34
35			This module represents a service discovery manager class.
36			You make instances of this class and get a handle to send
37			discovery requests like described in XEP-0030.
38
39			It also allows you to setup a disco-info/items tree
40			that others can walk and also lets you publish disco information.
41
42	elmex	1.6	This class is derived from L<Net::XMPP2::Ext> and can be added as extension to
43			objects that implement the L<Net::XMPP2::Extendable> interface or derive from
44			it.
45
46	elmex	1.1	=head1 METHODS
47
48	elmex	1.4	=over 4
49
50			=item B<new (%args)>
51	elmex	1.1
52	elmex	1.6	Creates a new disco handle.
53	elmex	1.1
54			=cut
55
56			sub new {
57			my $this = shift;
58			my $class = ref($this) \|\| $this;
59			my $self = bless { @_ }, $class;
60			$self->init;
61			$self
62			}
63
64			sub init {
65			my ($self) = @_;
66
67			$self->set_identity (client => console => 'Net::XMPP2');
68
69	elmex	1.6	$self->reg_cb (
70			iq_get_request_xml => sub {
71			my ($self, $con, $node, $handled_ref) = @_;
72			return 1 if $$handled_ref;
73	elmex	1.1
74	elmex	1.6	if ($self->handle_disco_query ($con, $node)) {
75			$$handled_ref = 1;
76			}
77	elmex	1.1
78	elmex	1.6	1
79			}
80			);
81	elmex	1.1	}
82
83	elmex	1.4	=item B<set_identity ($category, $type, $name)>
84	elmex	1.1
85			This sets the identity of the top info node.
86			The default is: C<$category = "client">, C<$type = "console">
87			and C<$name = "Net::XMPP2">.
88
89			C<$name> is optional and can be undef.
90
91			For a list of valid identites look at:
92
93			http://www.xmpp.org/registrar/disco-categories.html
94
95			Valid identity types for C<$category = "client"> may be:
96
97			bot
98			console
99			handheld
100			pc
101			phone
102			web
103
104			=cut
105
106			sub set_identity {
107			my ($self, $category, $type, $name) = @_;
108			$self->{iden}->{cat} = $category;
109			$self->{iden}->{type} = $type;
110			$self->{iden}->{name} = $name;
111			}
112
113
114	elmex	1.4	=item B<enable_feature ($uri)>
115	elmex	1.1
116			This method enables the feature C<$uri>, where C<$uri>
117			should be one of the values from the B<Name> column on:
118
119			http://www.xmpp.org/registrar/disco-features.html
120
121			These features are enabled by default:
122
123			http://jabber.org/protocol/disco#info
124			http://jabber.org/protocol/disco#items
125
126			=cut
127
128			sub enable_feature {
129			my ($self, $feature) = @_;
130			$self->{feat}->{$feature} = 1
131			}
132
133	elmex	1.4	=item B<disable_feature ($uri)>
134	elmex	1.1
135			This method enables the feature C<$uri>, where C<$uri>
136			should be one of the values from the B<Name> column on:
137
138			http://www.xmpp.org/registrar/disco-features.html
139
140			These features are enabled by default:
141
142			http://jabber.org/protocol/disco#info
143			http://jabber.org/protocol/disco#items
144
145			=cut
146
147			sub disable_feature {
148			my ($self, $feature) = @_;
149			delete $self->{feat}->{$feature}
150			}
151
152			sub write_feature {
153			my ($self, $w, $var) = @_;
154
155			$w->emptyTag ([xmpp_ns ('disco_info'), 'feature'], var => $var);
156			}
157
158			sub write_identity {
159			my ($self, $w, $cat, $type, $name) = @_;
160
161			$w->emptyTag ([xmpp_ns ('disco_info'), 'identity'],
162			category => $cat,
163			type => $type,
164			(defined $name ? (name => $name) : ())
165			);
166			}
167
168			sub handle_disco_query {
169	elmex	1.6	my ($self, $con, $node) = @_;
170	elmex	1.1
171			if ($node->find_all ([qw/disco_info query/])) {
172	elmex	1.6	$con->reply_iq_result (
173	elmex	1.1	$node, sub {
174			my ($w) = @_;
175
176			if ($node->attr ('node')) {
177			$w->addPrefix (xmpp_ns ('disco_info'), '');
178			$w->emptyTag ([xmpp_ns ('disco_info'), 'query']);
179
180			} else {
181			$w->addPrefix (xmpp_ns ('disco_info'), '');
182			$w->startTag ([xmpp_ns ('disco_info'), 'query']);
183			$self->write_identity ($w,
184			$self->{iden}->{cat},
185			$self->{iden}->{type},
186			$self->{iden}->{name},
187			);
188			$self->write_feature ($w, 'http://jabber.org/protocol/disco#info');
189			$self->write_feature ($w, 'http://jabber.org/protocol/disco#items');
190			$w->endTag;
191			}
192	elmex	1.6	},
193			to => $node->attr ('from')
194	elmex	1.1	);
195
196			return 1
197
198			} elsif ($node->find_all ([qw/disco_items query/])) {
199	elmex	1.6	$con->reply_iq_result (
200	elmex	1.1	$node, sub {
201			my ($w) = @_;
202
203			if ($node->attr ('node')) {
204			$w->addPrefix (xmpp_ns ('disco_items'), '');
205			$w->emptyTag ([xmpp_ns ('disco_items'), 'query']);
206
207			} else {
208			$w->addPrefix (xmpp_ns ('disco_items'), '');
209			$w->emptyTag ([xmpp_ns ('disco_items'), 'query']);
210			}
211	elmex	1.6	},
212			to => $node->attr ('from')
213	elmex	1.1	);
214
215			return 1
216			}
217
218			0
219			}
220
221			sub DESTROY {
222			my ($self) = @_;
223			$self->{connection}->unreg_cb ($self->{cb_id})
224			}
225
226	elmex	1.2
227	elmex	1.6	=item B<request_items ($con, $dest, $node, $cb)>
228	elmex	1.2
229			This method does send a items request to the JID entity C<$from>.
230			C<$node> is the optional node to send the request to, which can be
231			undef.
232	elmex	1.6	C<$con> must be an instance of L<Net::XMPP2::Connection> or a subclass of it.
233	elmex	1.2	The callback C<$cb> will be called when the request returns with 3 arguments:
234	elmex	1.3	the disco handle, an L<Net::XMPP2::Ext::Disco::Items> object (or undef)
235	elmex	1.2	and an L<Net::XMPP2::Error::IQ> object when an error occured and no items
236			were received.
237
238	elmex	1.6	$disco->request_items ($con, 'a@b.com', undef, sub {
239	elmex	1.2	my ($disco, $items, $error) = @_;
240			die $error->string if $error;
241
242			# do something with the items here ;_)
243			});
244
245			=cut
246
247			sub request_items {
248	elmex	1.6	my ($self, $con, $dest, $node, $cb) = @_;
249	elmex	1.2
250	elmex	1.6	$con->send_iq (
251	elmex	1.2	get => sub {
252			my ($w) = @_;
253			$w->addPrefix (xmpp_ns ('disco_items'), '');
254			$w->emptyTag ([xmpp_ns ('disco_items'), 'query'],
255			(defined $node ? (node => $node) : ())
256			);
257			},
258			sub {
259			my ($xmlnode, $error) = @_;
260			my $items;
261
262			if ($xmlnode) {
263			my (@query) = $xmlnode->find_all ([qw/disco_items query/]);
264	elmex	1.3	$items = Net::XMPP2::Ext::Disco::Items->new (
265	elmex	1.2	jid => $dest,
266			node => $node,
267			xmlnode => $query[0]
268			)
269			}
270
271			$cb->($self, $items, $error)
272			},
273			to => $dest
274			);
275			}
276
277	elmex	1.6	=item B<request_info ($con, $dest, $node, $cb)>
278	elmex	1.2
279			This method does send a info request to the JID entity C<$from>.
280			C<$node> is the optional node to send the request to, which can be
281			undef.
282	elmex	1.6	C<$con> must be an instance of L<Net::XMPP2::Connection> or a subclass of it.
283	elmex	1.2	The callback C<$cb> will be called when the request returns with 3 arguments:
284	elmex	1.3	the disco handle, an L<Net::XMPP2::Ext::Disco::Info> object (or undef)
285	elmex	1.2	and an L<Net::XMPP2::Error::IQ> object when an error occured and no items
286			were received.
287
288			$disco->request_info ('a@b.com', undef, sub {
289			my ($disco, $info, $error) = @_;
290			die $error->string if $error;
291
292			# do something with info here ;_)
293			});
294
295			=cut
296
297			sub request_info {
298	elmex	1.6	my ($self, $con, $dest, $node, $cb) = @_;
299	elmex	1.2
300	elmex	1.6	$con->send_iq (
301	elmex	1.2	get => sub {
302			my ($w) = @_;
303			$w->addPrefix (xmpp_ns ('disco_info'), '');
304			$w->emptyTag ([xmpp_ns ('disco_info'), 'query'],
305			(defined $node ? (node => $node) : ())
306			);
307			},
308			sub {
309			my ($xmlnode, $error) = @_;
310			my $info;
311
312			if ($xmlnode) {
313			my (@query) = $xmlnode->find_all ([qw/disco_info query/]);
314	elmex	1.3	$info = Net::XMPP2::Ext::Disco::Info->new (
315	elmex	1.2	jid => $dest,
316			node => $node,
317			xmlnode => $query[0]
318			)
319			}
320
321			$cb->($self, $info, $error)
322			},
323			to => $dest
324			);
325			}
326
327	elmex	1.4	=back
328
329	elmex	1.1	=head1 AUTHOR
330
331	elmex	1.4	Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
332	elmex	1.1
333			=head1 COPYRIGHT & LICENSE
334
335			Copyright 2007 Robin Redeker, all rights reserved.
336
337			This program is free software; you can redistribute it and/or modify it
338			under the same terms as Perl itself.
339
340			=cut
341
342			1;