XMPP2/Ext/Disco.pm

package Net::XMPP2::Ext::Disco;
use Net::XMPP2::Namespaces qw/xmpp_ns/;
use Net::XMPP2::Util qw/simxml/;
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

   use Net::XMPP2::Ext::Disco;

   my $con = Net::XMPP2::IM::Connection->new (...);
   $con->add_extension (my $disco = Net::XMPP2::Ext::Disco->new);
   $disco->request_items ('romeo@montague.net',
      sub {
         my ($disco, $items, $error) = @_;
         if ($error) { print "ERROR".$error->string."\n" }
         else {
            ... do something with the $items ...
         }
      }
   );

=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->enable_feature (xmpp_ns ('disco_info'));
   $self->enable_feature (xmpp_ns ('disco_items'));

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

         if ($self->handle_disco_query ($con, $node)) {
            return 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) = @_;

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

            if ($q->attr ('node')) {
               simxml ($w, defns => 'disco_info', node => {
                 ns => 'disco_info', name => 'query',
                 attrs => [ node => $q->attr ('node') ] 
               });

            } 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},
                  );
                  for (sort grep { $self->{feat}->{$_} } keys %{$self->{feat}}) {
                     $self->write_feature ($w, $_);
                  }
               $w->endTag;
            }
         },
         to => $node->attr ('from')
      );

      return 1

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

            if ($q->attr ('node')) {
               simxml ($w, defns => 'disco_items', node => {
                  ns    => 'disco_items',
                  name  => 'query',
                  attrs => [ node => $q->attr ('node') ]
               });

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