AnyEvent::XMPP::Ext::Disco - Service discovery manager class for XEP-0030

AnyEvent-XMPP documentation Contained in the AnyEvent-XMPP distribution.

Index

Code Index:

NAME

Top

AnyEvent::XMPP::Ext::Disco - Service discovery manager class for XEP-0030

SYNOPSIS

Top

   use AnyEvent::XMPP::Ext::Disco;

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

DESCRIPTION

Top

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 AnyEvent::XMPP::Ext and can be added as extension to objects that implement the AnyEvent::XMPP::Extendable interface or derive from it.

METHODS

Top

new (%args)

Creates a new disco handle.

set_identity ($category, $type, $name)

This sets the identity of the top info node.

$name is optional and can be undef. Please note that $name will overwrite all previous set names! If $name is undefined then no previous set name is overwritten.

For a list of valid identites look at:

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

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

   bot
   console
   handheld
   pc
   phone
   web
unset_identity ($category, $type)

This function removes the identity $category and $type.

enable_feature ($uri)

This method enables the feature $uri, where $uri should be one of the values from the 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

You can pass also a list of features you want to enable to enable_feature!

disable_feature ($uri)

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

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

You can pass also a list of features you want to disable to disable_feature!

request_items ($con, $dest, $node, $cb)

This method does send a items request to the JID entity $from. $node is the optional node to send the request to, which can be undef.

$con must be an instance of AnyEvent::XMPP::Connection or a subclass of it. The callback $cb will be called when the request returns with 3 arguments: the disco handle, an AnyEvent::XMPP::Ext::Disco::Items object (or undef) and an AnyEvent::XMPP::Error::IQ object when an error occured and no items were received.

The timeout of the request is the IQ timeout of the connection $con.

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

      # do something with the items here ;_)
   });
request_info ($con, $dest, $node, $cb)

This method does send a info request to the JID entity $from. $node is the optional node to send the request to, which can be undef.

$con must be an instance of AnyEvent::XMPP::Connection or a subclass of it. The callback $cb will be called when the request returns with 3 arguments: the disco handle, an AnyEvent::XMPP::Ext::Disco::Info object (or undef) and an AnyEvent::XMPP::Error::IQ object when an error occured and no items were received.

The timeout of the request is the IQ timeout of the connection $con.

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

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

AUTHOR

Top

Robin Redeker, <elmex at ta-sa.org>, JID: <elmex at jabber.org>

COPYRIGHT & LICENSE

Top

Copyright 2007, 2008 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.

AnyEvent-XMPP documentation Contained in the AnyEvent-XMPP distribution. 
package AnyEvent::XMPP::Ext::Disco;
use AnyEvent::XMPP::Namespaces qw/xmpp_ns/;
use AnyEvent::XMPP::Util qw/simxml/;
use AnyEvent::XMPP::Ext::Disco::Items;
use AnyEvent::XMPP::Ext::Disco::Info;
use AnyEvent::XMPP::Ext;
use strict;

our @ISA = qw/AnyEvent::XMPP::Ext/;


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

   # and features supported by AnyEvent::XMPP in general:
   $self->enable_feature (AnyEvent::XMPP::Ext::disco_feature_standard ());

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

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

         ()
      }
   );
}


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


sub unset_identity {
   my ($self, $category, $type) = @_;
   delete $self->{iden}->{$category}->{$type};
}


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


sub disable_feature {
   my ($self, @feature) = @_;
   delete $self->{feat}->{$_} for @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']);
                  for my $cat (keys %{$self->{iden}}) {
                     for my $type (keys %{$self->{iden}->{$cat}}) {
                        $self->write_identity ($w,
                           $cat, $type, $self->{iden_name}
                        );
                     }
                  }
                  for (sort grep { $self->{feat}->{$_} } keys %{$self->{feat}}) {
                     $self->write_feature ($w, $_);
                  }
               $w->endTag;
            }
         }
      );

      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'
               });
            }
         }
      );

      return 1
   }

   0
}

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



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 = AnyEvent::XMPP::Ext::Disco::Items->new (
               jid     => $dest,
               node    => $node,
               xmlnode => $query[0]
            )
         }

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


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 = AnyEvent::XMPP::Ext::Disco::Info->new (
               jid     => $dest,
               node    => $node,
               xmlnode => $query[0]
            )
         }

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


1;