##############################################################################
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# Library General Public License for more details.
#
# You should have received a copy of the GNU Library General Public
# License along with this library; if not, write to the
# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
#
# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
#
##############################################################################
package Net::XMPP::Roster;
=head1 NAME
Net::XMPP::Roster - XMPP Roster Object
=head1 SYNOPSIS
Net::XMPP::Roster is a module that provides a developer an easy
interface to an XMPP roster. It provides high level functions to
query, update, and manage a user's roster.
=head1 DESCRIPTION
The Roster object seeks to provide an easy to use API for interfacing
with a user's roster. When you instantiate it, it automatically
registers with the connection to receivce the correct packets so
that it can track all roster updates, and presence packets.
=head2 Basic Functions
my $Client = Net::XMPP::Client->new(...);
my $Roster = Net::XMPP::Roster->new(connection=>$Client);
or
my $Roster = $Client->Roster();
$Roster->clear();
if ($Roster->exists('bob@jabber.org')) { ... }
if ($Roster->exists(Net::XMPP::JID)) { ... }
if ($Roster->groupExists("Friends")) { ... }
my @groups = $Roster->groups();
my @jids = $Roster->jids();
my @friends = $Roster->jids("group","Friends");
my @unfiled = $Roster->jids("nogroup");
if ($Roster->online('bob@jabber.org')) { ... }
if ($Roster->online(Net::XMPP::JID)) { ... }
my %hash = $Roster->query('bob@jabber.org');
my %hash = $Roster->query(Net::XMPP::JID);
my $name = $Roster->query('bob@jabber.org',"name");
my $ask = $Roster->query(Net::XMPP::JID,"ask");
my $resource = $Roster->resource('bob@jabber.org');
my $resource = $Roster->resource(Net::XMPP::JID);
my %hash = $Roster->resourceQuery('bob@jabber.org',"Home");
my %hash = $Roster->resourceQuery(Net::XMPP::JID,"Club");
my $show = $Roster->resourceQuery('bob@jabber.org',"Home","show");
my $status = $Roster->resourceQuery(Net::XMPP::JID,"Work","status");
my @resource = $Roster->resources('bob@jabber.org');
my @resource = $Roster->resources(Net::XMPP::JID);
$Roster->resourceStore('bob@jabber.org',"Home","gpgkey",key);
$Roster->resourceStore(Net::XMPP::JID,"logged on","2004/04/07 ...");
$Roster->store('bob@jabber.org',"avatar",avatar);
$Roster->store(Net::XMPP::JID,"display_name","Bob");
=head2 Advanced Functions
These functions are only needed if you want to manually control
the Roster.
$Roster->add('bob@jabber.org',
name=>"Bob",
groups=>["Friends"]
);
$Roster->add(Net::XMPP::JID);
$Roster->addResource('bob@jabber.org',
"Home",
show=>"dnd",
status=>"Working"
);
$Roster->addResource(Net::XMPP::JID,"Work");
$Roster->remove('bob@jabber.org');
$Roster->remove(Net::XMPP::JID);
$Roster->removeResource('bob@jabber.org',"Home");
$Roster->removeResource(Net::XMPP::JID,"Work");
$Roster->handler(Net::XMPP::IQ);
$Roster->handler(Net::XMPP::Presence);
=head1 METHODS
=head2 Basic Functions
=over 4
=item new
new(connection=>object)
This creates and initializes the Roster
object. The connection object is required
so that the Roster can interact with the
main connection object. It needs to be an
object that inherits from L<Net::XMPP::Connection>.
=item clear
clear()
removes everything from the database.
=item exists
exists(jid)
return 1 if the JID exists in the database, undef
otherwise. The jid can either be a string, or a L<Net::XMPP::JID> object.
=item groupExists
groupExists(group)
return 1 if the group exists in the database, undef otherwise.
=item groups
groups()
Returns a list of all of the roster groups.
=item jids
jids([type, [group]])
returns a list of all of the matching JIDs. The valid
types are:
all - return all JIDs in the roster. (default)
nogroup - return all JIDs not in a roster group.
group - return all of the JIDs in the specified
roster group.
=item online
online(jid)
return 1 if the JID is online, undef otherwise. The
jid can either be a string, or a L<Net::XMPP::JID> object.
=item query
query(jid, [key])
return a hash representing all of the data in the
DB for this JID. The jid can either be a string,
or a Net::XMPP::JID object. If you specify a key,
then only the value for that key is returned.
=item resource
resource(jid)
return the string representing the resource with the
highest priority for the JID. The jid can either be
a string, or a Net::XMPP::JID object.
=item resourceQuery
resourceQuery(jid,
resource,
[key])
return a hash representing all of the data
the DB for the resource for this JID. The
jid can either be a string, or a
Net::XMPP::JID object. If you specify a
key, then only the value for that key is
returned.
=item resources
resources(jid)
returns the list of resources for the JID in order
of highest priority to lowest priority. The jid can
either be a string, or a Net::XMPP::JID object.
=item resourceStore
resourceStore(jid,
resource,
key,
value)
store the specified value in the DB under
the specified key for the resource for this
JID. The jid can either be a string, or a
Net::XMPP::JID object.
=item store
store(jid, key, value)
store the specified value in the DB under the
specified key for this JID. The jid can either
be a string, or a Net::XMPP::JID object.
=back
=head2 Advanced Functions
add(jid, - Manually adds the JID to the Roster with the
ask=>string, specified roster item settings. This does not
groups=>arrayref handle subscribing to other users, only
name=>string, manipulating the Roster object. The jid
subscription=>string) can either be a string or a Net::XMPP::JID.
addResource(jid, - Manually add the resource to the JID in the
resource, Roster with the specified presence settings.
priority=>int, This does not handle subscribing to other
show=>string, users, only manipulating the Roster object.
status=>string) The jid can either be a string or a
Net::XMPP::JID.
remove(jid) - Removes all reference to the JID from the Roster object.
The jid can either be a string or a Net::XMPP::JID.
removeResource(jid, - Removes the resource from the jid in the
resource) Roster object. The jid can either be a string
or a Net::XMPP::JID.
handler(packet) - Take either a Net::XMPP::IQ or Net::XMPP::Presence
packet and parse them according to the rules of the
Roster object. Note, that it will only waste CPU time
if you pass in IQs or Presences that are not roster
related.
=head1 AUTHOR
Originally authored by Ryan Eatmon.
Previously maintained by Eric Hacker.
Currently maintained by Darian Anthony Patrick.
=head1 COPYRIGHT
This module is free software, you can redistribute it and/or modify it
under the LGPL 2.1.
=cut
use 5.008;
use strict;
use warnings;
use Carp;
use Net::XMPP::JID;
use Scalar::Util qw(weaken);
sub new
{
my $proto = shift;
my $self = { };
my %args;
while($#_ >= 0) { $args{ lc(pop(@_)) } = pop(@_); }
if (!exists($args{connection}) ||
!$args{connection}->isa("Net::XMPP::Connection"))
{
croak("You must pass Net::XMPP::Roster a valid connection object.");
}
$self->{CONNECTION} = $args{connection};
bless($self, $proto);
$self->init();
return $self;
}
##############################################################################
#
# init - initialize the module to use the roster database
#
##############################################################################
sub init
{
my $self = shift;
my $weak = $self;
weaken $weak;
$self->{CONNECTION}-> SetXPathCallBacks('/iq[@type="result" or @type="set"]/query[@xmlns="jabber:iq:roster"]'=>sub{ $weak->handler(@_) });
$self->{CONNECTION}-> SetXPathCallBacks('/presence'=>sub{ $weak->handler(@_) });
}
##############################################################################
#
# add - adds the entry to the Roster DB.
#
##############################################################################
sub add
{
my $self = shift;
my ($jid,%item) = @_;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
$self->{JIDS}->{$jid} = \%item;
if (exists($item{groups}))
{
foreach my $group (@{$item{groups}})
{
$self->{GROUPS}->{$group}->{$jid} = 1;
}
}
}
##############################################################################
#
# addResource - adds the resource to the JID in the Roster DB.
#
##############################################################################
sub addResource
{
my $self = shift;
my $jid = shift;
my $resource = shift;
my (%item) = @_;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
my $priority = $item{priority};
$priority = 0 unless defined($priority);
$self->{CONNECTION}->{DEBUG}->Log3("Roster::addResource: add $jid/$resource with priority $priority to the DB");
my $loc = -1;
$self->{JIDS}->{$jid}->{priorities}->{$priority} = []
unless exists($self->{JIDS}->{$jid}->{priorities}->{$priority});
foreach my $index (0..$#{$self->{JIDS}->{$jid}->{priorities}->{$priority}})
{
$loc = $index
if ($self->{JIDS}->{$jid}->{priorities}->{$priority}->[$index]->{resource} eq $resource);
}
$loc = $#{$self->{JIDS}->{$jid}->{priorities}->{$priority}} + 1 if ($loc == -1);
$self->{JIDS}->{$jid}->{resources}->{$resource}->{priority} = $priority;
$self->{JIDS}->{$jid}->{resources}->{$resource}->{status} = $item{status}
if exists($item{status});
$self->{JIDS}->{$jid}->{resources}->{$resource}->{show} = $item{show}
if exists($item{show});
$self->{JIDS}->{$jid}->{priorities}->{$priority}->[$loc]->{resource} = $resource;
}
###############################################################################
#
# clear - delete all of the JIDs from the DB completely.
#
###############################################################################
sub clear
{
my $self = shift;
$self->{CONNECTION}->{DEBUG}->Log3("Roster::clear: clearing the database");
foreach my $jid ($self->jids())
{
$self->remove($jid);
}
$self->{CONNECTION}->{DEBUG}->Log3("Roster::clear: database is empty");
}
##############################################################################
#
# exists - allows you to query if the JID exists in the Roster DB.
#
##############################################################################
sub exists
{
my $self = shift;
my ($jid) = @_;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
return unless exists($self->{JIDS});
return unless exists($self->{JIDS}->{$jid});
return 1;
}
sub fetch
{
my $self = shift;
my %newroster = $self->{CONNECTION}->RosterGet();
$self->handleRoster(\%newroster);
}
##############################################################################
#
# groupExists - allows you to query if the group exists in the Roster
# DB.
#
##############################################################################
sub groupExists
{
my $self = shift;
my ($group) = @_;
return unless exists($self->{GROUPS});
return unless exists($self->{GROUPS}->{$group});
return 1;
}
##############################################################################
#
# groups - returns a list of the current groups in your roster.
#
##############################################################################
sub groups
{
my $self = shift;
return () unless exists($self->{GROUPS});
return () if (scalar(keys(%{$self->{GROUPS}})) == 0);
return keys(%{$self->{GROUPS}});
}
##############################################################################
#
# handler - takes a packet and calls the correct handler.
#
##############################################################################
sub handler
{
my $self = shift;
my $sid = shift;
my $packet = shift;
$self->handleIQ($packet) if ($packet->GetTag() eq "iq");
$self->handlePresence($packet) if ($packet->GetTag() eq "presence");
}
##############################################################################
#
# handleIQ - takes an iq packet that contains roster, parses it, and puts
# the roster into the Roster DB.
#
##############################################################################
sub handleIQ
{
my $self = shift;
my $iq = shift;
$self->{CONNECTION}->{DEBUG}->Log3('handleIQ: iq(' . $iq->GetXML() . ')');
my $type = $iq->GetType();
return unless (($type eq "set") || ($type eq "result"));
my %newroster = $self->{CONNECTION}->RosterParse($iq);
$self->handleRoster(\%newroster);
}
sub handleRoster
{
my $self = shift;
my $roster = shift;
foreach my $jid (keys(%{$roster}))
{
$self->remove($jid);
if ($roster->{$jid}->{subscription} ne "remove")
{
$self->add($jid, %{$roster->{$jid}});
}
}
}
##############################################################################
#
# handlePresence - takes a presence packet and groks the presence.
#
##############################################################################
sub handlePresence
{
my $self = shift;
my $presence = shift;
$self->{CONNECTION}->{DEBUG}->Log3('handlePresence: presence(' . $presence->GetXML() . ')');
my $type = $presence->GetType();
$type = "" unless defined($type);
return unless (($type eq "") ||
($type eq "available") ||
($type eq "unavailable"));
my $jid = $presence->GetFrom("jid");
my $resource = $jid->GetResource();
$resource = " " unless ($resource ne "");
$jid = $jid->GetJID();
$jid = "" unless defined($jid);
return unless $self->exists($jid);
#XXX if it doesn't exist... is it us?
#XXX is this a presence based roster?
$self->{CONNECTION}->{DEBUG}->Log3("Roster::PresenceDBParse: fromJID(",$presence->GetFrom(),") resource($resource) type($type)");
$self->{CONNECTION}->{DEBUG}->Log4("Roster::PresenceDBParse: xml(",$presence->GetXML(),")");
$self->removeResource($jid,$resource);
if (($type eq "") || ($type eq "available"))
{
my %item;
$item{priority} = $presence->GetPriority();
$item{priority} = 0 unless defined($item{priority});
$item{show} = $presence->GetShow();
$item{show} = "" unless defined($item{show});
$item{status} = $presence->GetStatus();
$item{status} = "" unless defined($item{status});
$self->addResource($jid,$resource,%item);
}
}
##############################################################################
#
# jids - returns a list of all of the JIDs in your roster.
#
##############################################################################
sub jids
{
my $self = shift;
my $type = shift;
my $group = shift;
$type = "all" unless defined($type);
my @jids;
if (($type eq "all") || ($type eq "nogroup"))
{
return () unless exists($self->{JIDS});
foreach my $jid (keys(%{$self->{JIDS}}))
{
next if (($type eq "nogroup") &&
exists($self->{JIDS}->{$jid}->{groups}) &&
($#{$self->{JIDS}->{$jid}->{groups}} > -1));
push(@jids, Net::XMPP::JID->new($jid));
}
}
if ($type eq "group")
{
return () unless exists($self->{GROUPS});
if (defined($group) && $self->groupExists($group))
{
foreach my $jid (keys(%{$self->{GROUPS}->{$group}}))
{
push(@jids, Net::XMPP::JID->new($jid));
}
}
}
return @jids;
}
###############################################################################
#
# online - returns if the jid is online or not.
#
###############################################################################
sub online
{
my $self = shift;
my $jid = shift;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
return unless $self->exists($jid);
my @resources = $self->resources($jid);
return ($#resources > -1);
}
##############################################################################
#
# priority - return the highest priority for the jid, or for the specified
# resource.
#
##############################################################################
sub priority
{
my $self = shift;
my $jid = shift;
my $resource = shift;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
if (defined($resource))
{
return unless $self->resourceExists($jid,$resource);
return unless exists($self->{JIDS}->{$jid}->{resources}->{$resource}->{priority});
return $self->{JIDS}->{$jid}->{resources}->{$resource}->{priority};
}
return unless exists($self->{JIDS}->{$jid}->{priorities});
my @priorities = sort{ $b <=> $a } keys(%{$self->{JIDS}->{$jid}->{priorities}});
return $priorities[0];
}
##############################################################################
#
# query - allows you to get one of the pieces of info from the Roster DB.
#
##############################################################################
sub query
{
my $self = shift;
my $jid = shift;
my $key = shift;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
return unless $self->exists($jid);
if (defined($key))
{
return unless exists($self->{JIDS}->{$jid}->{$key});
return $self->{JIDS}->{$jid}->{$key};
}
return %{$self->{JIDS}->{$jid}};
}
##############################################################################
#
# remove - removes the JID from the Roster DB.
#
##############################################################################
sub remove
{
my $self = shift;
my $jid = shift;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
if ($self->exists($jid))
{
$self->{CONNECTION}->{DEBUG}->Log3("Roster::remove: deleting $jid from the DB");
if (defined($self->query($jid,"groups")))
{
foreach my $group (@{$self->query($jid,"groups")})
{
delete($self->{GROUPS}->{$group}->{$jid});
delete($self->{GROUPS}->{$group})
if (scalar(keys(%{$self->{GROUPS}->{$group}})) == 0);
delete($self->{GROUPS})
if (scalar(keys(%{$self->{GROUPS}})) == 0);
}
}
delete($self->{JIDS}->{$jid});
delete($self->{JIDS}) if (scalar(keys(%{$self->{JIDS}})) == 0);
}
}
##############################################################################
#
# removeResource - removes the resource from the JID from the Roster DB.
#
##############################################################################
sub removeResource
{
my $self = shift;
my $jid = shift;
my $resource = shift;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
if ($self->resourceExists($jid,$resource))
{
$self->{CONNECTION}->{DEBUG}->Log3("Roster::removeResource: remove $jid/$resource from the DB");
my $oldPriority = $self->priority($jid,$resource);
$oldPriority = "" unless defined($oldPriority);
if (exists($self->{JIDS}->{$jid}->{priorities}->{$oldPriority}))
{
my $loc = 0;
foreach my $index (0..$#{$self->{JIDS}->{$jid}->{priorities}->{$oldPriority}})
{
$loc = $index
if ($self->{JIDS}->{$jid}->{priorities}->{$oldPriority}->[$index]->{resource} eq $resource);
}
splice(@{$self->{JIDS}->{$jid}->{priorities}->{$oldPriority}},$loc,1);
delete($self->{JIDS}->{$jid}->{priorities}->{$oldPriority})
if (exists($self->{JIDS}->{$jid}->{priorities}->{$oldPriority}) &&
($#{$self->{JIDS}->{$jid}->{priorities}->{$oldPriority}} == -1));
}
delete($self->{JIDS}->{$jid}->{resources}->{$resource});
}
}
###############################################################################
#
# resource - retrieve the resource with the highest priority.
#
###############################################################################
sub resource
{
my $self = shift;
my $jid = shift;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
return unless $self->exists($jid);
my $priority = $self->priority($jid);
return unless defined($priority);
return $self->{JIDS}->{$jid}->{priorities}->{$priority}->[0]->{resource};
}
##############################################################################
#
# resourceExists - check that the specified resource exists.
#
##############################################################################
sub resourceExists
{
my $self = shift;
my $jid = shift;
my $resource = shift;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
return unless $self->exists($jid);
return unless exists($self->{JIDS}->{$jid}->{resources});
return unless exists($self->{JIDS}->{$jid}->{resources}->{$resource});
}
##############################################################################
#
# resourceQuery - allows you to get one of the pieces of info from the Roster
# DB.
#
##############################################################################
sub resourceQuery
{
my $self = shift;
my $jid = shift;
my $resource = shift;
my $key = shift;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
return unless $self->resourceExists($jid,$resource);
if (defined($key))
{
return unless exists($self->{JIDS}->{$jid}->{resources}->{$resource}->{$key});
return $self->{JIDS}->{$jid}->{resources}->{$resource}->{$key};
}
return %{$self->{JIDS}->{$jid}->{resources}->{$resource};}
}
###############################################################################
#
# resources - returns a list of the resources from highest priority to lowest.
#
###############################################################################
sub resources
{
my $self = shift;
my $jid = shift;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
return () unless $self->exists($jid);
my @resources;
foreach my $priority (sort {$b cmp $a} keys(%{$self->{JIDS}->{$jid}->{priorities}}))
{
foreach my $index (0..$#{$self->{JIDS}->{$jid}->{priorities}->{$priority}})
{
next if ($self->{JIDS}->{$jid}->{priorities}->{$priority}->[$index]->{resource} eq " ");
push(@resources,$self->{JIDS}->{$jid}->{priorities}->{$priority}->[$index]->{resource});
}
}
return @resources;
}
##############################################################################
#
# resourceStore - allows you to store anything on the item that you want to.
# The only drawback is that when the item is removed, the data
# is not kept. You must restore it in the DB.
#
##############################################################################
sub resourceStore
{
my $self = shift;
my $jid = shift;
my $resource = shift;
my $key = shift;
my $value = shift;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
return unless defined($key);
return unless defined($value);
return unless $self->resourceExists($jid,$resource);
$self->{JIDS}->{$jid}->{resources}->{$resource}->{$key} = $value;
}
##############################################################################
#
# store - allows you to store anything on the item that you want to. The
# only drawback is that when the item is removed, the data is not
# kept. You must restore it in the DB.
#
##############################################################################
sub store
{
my $self = shift;
my $jid = shift;
my $key = shift;
my $value = shift;
$jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
return unless defined($key);
return unless defined($value);
return unless $self->exists($jid);
$self->{JIDS}->{$jid}->{$key} = $value;
}
1;