File Coverage

blib/lib/JOAP/Proxy/Class.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

# JOAP::Proxy::Class.pm - class for classes that are classes
#
# Copyright (c) {$YEAR}, {$NAME} {$EMAIL}.
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 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
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser 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

# tag: JOAP class proxy object class

package JOAP::Proxy::Class;
use JOAP::Proxy;
use JOAP::Proxy::Instance;
use base qw/JOAP::Proxy/;

use 5.008;
use strict;
use warnings;

our %EXPORT_TAGS = ( 'all' => [ qw// ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw//;

our $VERSION = $JOAP::VERSION;
our $AUTOLOAD;

sub superclasses {
    my $self = shift;
    return (@_) ? $self->{_superclasses} = shift : $self->{_superclasses};
}

sub _describe {
    my $self = shift;
    my $resp = $self->SUPER::_describe(@_);

    my @classes = $resp->GetQuery->GetSuperclass;
    $self->superclasses(\@classes);

    return $resp;
}

sub _default_edit_attrs {

    my $self = shift;

    # This _should_ return only writable attributes

    my $attrs = $self->SUPER::_default_edit_attrs;

    my @right_alloc = grep { $attrs->{$_}->{allocation} eq 'class' } keys %$attrs;

    # make that into a hash

    my %write = map {($_, $attrs->{$_})} @right_alloc;

    # return a reference to that hash

    return \%write;
}

sub can {
    my $self = shift;
    my $name = shift;
    my $func = $self->UNIVERSAL::can($name); # See if it's findable by standard lookup.

    if (!$func) { # if not, see if it's something we should make ourselves.
        my $methdesc = $self->_method_descriptor($name);

        if ($methdesc && $methdesc->{allocation} eq 'class') {
            $func = $self->_proxy_method($methdesc);
	} else {
            my $attrdesc = $self->_attribute_descriptor($name);
            if ($attrdesc && $attrdesc->{allocation} eq 'class') {
                $func = $self->_proxy_accessor($attrdesc);
            }
        }
    }

    return $func;
}

sub add {

    my $self = shift;

    my %args = @_;

    my $con = $self->Connection || throw JOAP::Proxy::Error::Local("Can't add without a connection.");

    # Servers will of course do these checks for us, because they need
    # to preserve their data integrity. However, we save some time
    # failing early if we know what the problem is.

    # check to see that all params are in our class

    my @unmatched = grep { !$self->_attribute_descriptor($_) } keys %args;

    if (@unmatched) {
        throw JOAP::Proxy::Error::Local("Unknown attributes: " . join(",", @unmatched));
    }

    # check to see that all params are writable

    my @unwritable = grep { ! $self->_attribute_descriptor($_)->{writable} } keys %args;

    if (@unwritable) {
        throw JOAP::Proxy::Error::Local("Read-only attributes: " . join(",", @unwritable));
    }

    # check to see that all params are instance

    my @noninst = grep { $self->_attribute_descriptor($_)->{allocation} ne 'instance' } keys %args;

    if (@noninst) {
        throw JOAP::Proxy::Error::Local("Non-instance attributes: " . join(",", @noninst));
    }

    my $attrdesc = $self->attributes;

    # check to see that all required, writable instance attrs are present

    my @reqwrite =
      grep { my $desc = $attrdesc->{$_};
             $desc->{required} &&
               $desc->{writable} &&
               ($desc->{allocation} eq 'instance')} keys %$attrdesc;

    my @unfulfill = grep { ! exists $args{$_} } @reqwrite;

    if (@unfulfill) {
        throw JOAP::Proxy::Error::Local("Required, writable instance attributes not provided: " . join (",", @unfulfill));
    }

    # Hooray! We're validated. Let's send the message already.

    my $iq = new Net::Jabber::IQ();
    $iq->SetIQ(to => $self->address, type => 'set');

    my $add = $iq->NewQuery($JOAP::NS, 'add');

    while (my ($name, $arg) = each %args) {
        my $attr = $add->AddAttribute(name => $name);
        my $value = $attr->AddValue;
        my $enc = JOAP->encode($self->_attribute_descriptor($name)->{type}, $arg);
        JOAP->copy_value($enc, $value);
    }

    my $resp = $con->SendAndReceiveWithID($iq);

    if ($resp->GetType eq 'error') {
	throw JOAP::Proxy::Error::Remote($resp->GetError, $resp->GetErrorCode);
    }

    my $addr = $resp->GetQuery->GetNewAddress;

    return $self->_get_instance($addr);
}

# We want to be able to overload this in subclasses.

sub _get_instance {

    my $self = shift;
    my $addr = shift;

    # XXX: This is a little iffy, since it requires a round-trip to
    # the server, even though we know some of the attributes. But a
    # re-read is probably the safest thing.

    return JOAP::Proxy::Instance->get($addr,
                                      methods => $self->methods,
                                      attributes => $self->attributes,
                                      superclasses => $self->superclasses,
                                      description => $self->description,
                                      timestamp => $self->timestamp);
}

sub search {

    my $self = shift;

    my %args = @_;

    my $con = $self->Connection || throw JOAP::Proxy::Error::Local("Can't search without a connection.");

    # Servers will of course do these checks for us, because they need
    # to preserve their data integrity. However, we save some time
    # failing early if we know what the problem is.

    # Are there any attrs to search that aren't in our object?

    my @unknown = grep { !$self->_attribute_descriptor($_) } keys %args;

    if (@unknown) {
	throw JOAP::Proxy::Error::Local("Unknown attributes: " . join(",", @unknown));
    }

    # Are there any class attributes in there?

    my @classattrs = grep {$self->_attribute_descriptor($_)->{allocation} eq 'class'} keys %args;

    if (@classattrs) {
	throw JOAP::Proxy::Error::Local("Can't search on class attributes: " . join(",", @classattrs));
    }

    # Well, that's about all we can do.

    my $iq = new Net::Jabber::IQ();
    $iq->SetIQ(to => $self->address, type => 'get');

    my $search = $iq->NewQuery($JOAP::NS, 'search');

    while (my ($name, $arg) = each %args) {
        my $attr = $search->AddAttribute(name => $name);
        my $value = $attr->AddValue;
        my $enc = JOAP->encode($self->_attribute_descriptor($name)->{type}, $arg);
        JOAP->copy_value($enc, $value);
    }

    my $resp = $con->SendAndReceiveWithID($iq);

    if ($resp->GetType eq 'error') {
	throw JOAP::Proxy::Error::Remote(value => $resp->GetErrorCode, text => $resp->GetError);
    }

    # This is going to be a list of address strings

    my @items = $resp->GetQuery->GetItem;

    return @items;
}

1;  # don't forget to return a true value from the file

__END__