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;

=head1 NAME

Net::XMPP2::Ext::Disco - A 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.

=head1 METHODS

=head2 new (%args)

Creates a new disco handle. Possible keys for the C<%args> hash are:

=over 4

=item connection => $connection

The connection this handle will send the requests with and
answer requests.

=back

=cut

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

sub init {
   my ($self) = @_;
   my $con = $self->{connection};

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

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

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

            1
         }
      );
}

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


=head2 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
}

=head2 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, $node) = @_;
   warn "HANDL\n";

   if ($node->find_all ([qw/disco_info query/])) {
      $self->{connection}->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;
            }
         }
      );

      return 1

   } elsif ($node->find_all ([qw/disco_items query/])) {
      $self->{connection}->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']);
            }
         }
      );

      return 1
   }

   0
}

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


=head2 request_items ($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.
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 ('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, $dest, $node, $cb) = @_;

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

=head2 request_info ($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.
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, $dest, $node, $cb) = @_;

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

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