File Coverage

blib/lib/Net/XMPP/PrivacyLists.pm

Criterion	Covered	Total	%
statement	12	111	10.8
branch	0	26	0.0
condition	0	6	0.0
subroutine	4	23	17.3
pod	0	18	0.0
total	16	184	8.7

##############################################################################
#
#  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::PrivacyLists;

=head1 NAME

Net::XMPP::PrivacyLists - XMPP Privacy Lists Object

=head1 SYNOPSIS

This module is not yet complete.  Do not use.

=head1 DESCRIPTION

=head2 Basic Functions

=head2 Advanced Functions

=head1 METHODS

=head2 Basic Functions

=head2 Advanced Functions

=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

require 5.003;
use strict;
use warnings;

use Carp;
use XML::Stream;

sub new
{
    my $proto = shift;
    my $self = { };

    my %args;
    while($#_ >= 0) { $args{ lc(pop(@_)) } = pop(@_); }

    $self->{CONNECTION} = $args{connection};

    bless($self, $proto);

    $self->init();

    return $self;
}


##############################################################################
#
# init - initialize the module to use the privacy lists.
#
##############################################################################
sub init
{
    my $self = shift;

    $self->{CONNECTION}-> SetXPathCallBacks('/iq[@type="result" or @type="set"]/query[@xmlns="jabber:iq:privacy"]'=>sub{ $self->handler(@_) });
}


##############################################################################
#
# debug - print out a representation of the privacy lists.
#
##############################################################################
sub debug
{
    my $self = shift;

    &XML::Stream::printData("\$self->{LISTS}",$self->{LISTS});
}


##############################################################################
#
# addItem - add list item to a list.
#
##############################################################################
sub addItem
{
    my $self = shift;
    my ($list,%item) = @_;

    my $order = delete($item{order});
    $self->{LISTS}->{$list}->{$order} = \%item;
}


###############################################################################
#
# clear - delete all of the JIDs from the DB completely.
#
###############################################################################
sub clear
{
    my $self = shift;

    $self->{CONNECTION}->{DEBUG}->Log3("PrivacyLists::clear: clearing the database");
    foreach my $list ($self->lists())
    {
        $self->remove($list);
    }
    $self->{CONNECTION}->{DEBUG}->Log3("PrivacyLists::clear: database is empty");
}


##############################################################################
#
# exists - allows you to query if the JID exists in the Roster DB.
#
##############################################################################
sub exists
{
    my $self = shift;
    my $list = shift;

    return unless exists($self->{LISTS});
    return unless exists($self->{LISTS}->{$list});
    return 1;
}


##############################################################################
#
# fetch - fetch the privacy lists from the server and populate the database.
#
##############################################################################
sub fetch
{
    my $self = shift;

    my $iq = $self->{CONNECTION}->PrivacyListsGet();
    $self->handleIQ($iq);
}


##############################################################################
#
# fetchList - fetch the privacy list from the server and populate the database.
#
##############################################################################
sub fetchList
{
    my $self = shift;
    my $list = shift;

    my $iq = $self->{CONNECTION}->PrivacyListsGet(list=>$list);
    $self->handleIQ($iq);
}


##############################################################################
#
# lists - returns a list of the current privacy lists.
#
##############################################################################
sub lists
{
    my $self = shift;

    return () unless exists($self->{LISTS});
    return () if (scalar(keys(%{$self->{LISTS}})) == 0);
    return keys(%{$self->{LISTS}});
}


##############################################################################
#
# items - returns a list of all of the items in the specified privacy list.
#
##############################################################################
sub items
{
    my $self = shift;
    my $list = shift;

    my @items;

    return () unless $self->exists($list);
    foreach my $order (sort{ $a <=> $b } keys(%{$self->{LISTS}->{$list}}))
    {
        my %item = %{$self->{LISTS}->{$list}->{$order}};
        $item{order} = $order;
        push(@items,\%item);
    }

    return @items;
}


##############################################################################
#
# 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");
}


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

    print "handleIQ: iq(",$iq->GetXML(),")\n";

    my $type = $iq->GetType();
    return unless (($type eq "set") || ($type eq "result"));

    if ($type eq "result")
    {
        my $query = $iq->GetChild("jabber:iq:privacy");

        my @lists = $query->GetLists();

        return unless ($#lists > -1);

        my @items = $lists[0]->GetItems();

        if (($#lists == 0) && ($#items > -1))
        {
            $self->parseList($lists[0]);
        }
        elsif ($#lists >= -1)
        {
            $self->parseLists(\@lists);
        }
    }
}


sub parseList
{
    my $self = shift;
    my $list = shift;

    my $name = $list->GetName();

    foreach my $item ($list->GetItems())
    {
        my %item = $item->GetItem();

        $self->addItem($name,%item);
    }
}


sub parseLists
{
    my $self = shift;
    my $lists = shift;

    foreach my $list (@{$lists})
    {
        my $name = $list->GetName();
        $self->fetchList($name);
    }
}


##############################################################################
#
# reload - clear and refetch the privacy lists.
#
##############################################################################
sub reload
{
    my $self = shift;

    $self->clear();
    $self->fetch();
}


##############################################################################
#
# remove - removes the list from the database.
#
##############################################################################
sub remove
{
    my $self = shift;
    my $list = shift;

    if ($self->exists($list))
    {
        $self->{CONNECTION}->{DEBUG}->Log3("PrivacyLists::remove: deleting $list from the DB");

        delete($self->{LISTS}->{$list});
        delete($self->{LISTS}) if (scalar(keys(%{$self->{LISTS}})) == 0);
    }
}


sub save
{
    my $self = shift;

    foreach my $list ($self->lists())
    {
        $self->saveList($list);
    }
}


sub saveList
{
    my $self = shift;
    my $list = shift;

    my @items = $self->items($list);
    $self->{CONNECTION}->PrivacyListsSet(list=>$list,
                                         items=>\@items);
}


1;