XMPP2/Ext/Disco.pm

package Net::XMPP2::Disco;
use Net::XMPP2::Namespaces qw/xmpp_ns/;

=head1 NAME

Net::XMPP2::Disco - A service discovery manager class for XEP-0030

=head1 SYNOPSIS

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

   my $con = Net::XMPP2::IM::Connection->new (...);
   ...
   my $disco = Net::XMPP2::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})
}

=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.1
Committed:	Wed Apr 25 13:18:36 2007 UTC (19 years, 5 months ago) by elmex
Branch:	MAIN
Log Message:	added Disco support!
#	User	Rev	Content
1	elmex	1.1	package Net::XMPP2::Disco;
2			use Net::XMPP2::Namespaces qw/xmpp_ns/;
3
4			=head1 NAME
5
6			Net::XMPP2::Disco - A service discovery manager class for XEP-0030
7
8			=head1 SYNOPSIS
9
10			package foo;
11			use Net::XMPP2::Disco;
12
13			my $con = Net::XMPP2::IM::Connection->new (...);
14			...
15			my $disco = Net::XMPP2::Disco->new (connection => $con);
16
17			$disco->request_items ('romeo@montague.net',
18			node => 'http://jabber.org/protocol/tune',
19			cb => sub {
20			my ($disco, $response, $error) = @_;
21			if ($error) { print "ERROR".$error->string."\n" }
22			else {
23			... do something with the $response ...
24			}
25			}
26			);
27
28			=head1 DESCRIPTION
29
30			This module represents a service discovery manager class.
31			You make instances of this class and get a handle to send
32			discovery requests like described in XEP-0030.
33
34			It also allows you to setup a disco-info/items tree
35			that others can walk and also lets you publish disco information.
36
37			=head1 METHODS
38
39			=head2 new (%args)
40
41			Creates a new disco handle. Possible keys for the C<%args> hash are:
42
43			=over 4
44
45			=item connection => $connection
46
47			The connection this handle will send the requests with and
48			answer requests.
49
50			=back
51
52			=cut
53
54			sub new {
55			my $this = shift;
56			my $class = ref($this) \|\| $this;
57			my $self = bless { @_ }, $class;
58			$self->init;
59			$self
60			}
61
62			sub init {
63			my ($self) = @_;
64			my $con = $self->{connection};
65
66			$self->set_identity (client => console => 'Net::XMPP2');
67
68			$self->{cb_id} =
69			$con->reg_cb (
70			iq_get_request_xml => sub {
71			my ($con, $node, $handled_ref) = @_;
72			return 1 if $$handled_ref;
73
74			if ($self->handle_disco_query ($node)) {
75			$$handled_ref = 1;
76			}
77
78			1
79			}
80			);
81			}
82
83			=head2 set_identity ($category, $type, $name)
84
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			=head2 enable_feature ($uri)
115
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			=head2 disable_feature ($uri)
134
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			my ($self, $node) = @_;
170			warn "HANDL\n";
171
172			if ($node->find_all ([qw/disco_info query/])) {
173			$self->{connection}->reply_iq_result (
174			$node, sub {
175			my ($w) = @_;
176
177			if ($node->attr ('node')) {
178			$w->addPrefix (xmpp_ns ('disco_info'), '');
179			$w->emptyTag ([xmpp_ns ('disco_info'), 'query']);
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			$self->write_feature ($w, 'http://jabber.org/protocol/disco#info');
190			$self->write_feature ($w, 'http://jabber.org/protocol/disco#items');
191			$w->endTag;
192			}
193			}
194			);
195
196			return 1
197
198			} elsif ($node->find_all ([qw/disco_items query/])) {
199			$self->{connection}->reply_iq_result (
200			$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			}
212			);
213
214			return 1
215			}
216
217			0
218			}
219
220			sub DESTROY {
221			my ($self) = @_;
222			$self->{connection}->unreg_cb ($self->{cb_id})
223			}
224
225			=head1 AUTHOR
226
227			Robin Redeker, C<< <elmex at ta-sa.org> >>
228
229			=head1 COPYRIGHT & LICENSE
230
231			Copyright 2007 Robin Redeker, all rights reserved.
232
233			This program is free software; you can redistribute it and/or modify it
234			under the same terms as Perl itself.
235
236			=cut
237
238			1;