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

=over 4

=item B<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
         }
      );
}

=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, $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})
}


=item B<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
   );
}

=item B<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
   );
}

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