File Coverage

blib/lib/JOAP/Server/Class.pm

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

# JOAP::Server::Class -- Base Class for JOAP Server-Side Classes and Instances
#
# Copyright (c) 2003, Evan Prodromou
#
# 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 server class framework

package JOAP::Server::Class;
use base qw/Exporter JOAP::Server::Object/;

use 5.008;
use strict;
use warnings;

use Net::Jabber qw/Component/;
use JOAP;
use JOAP::Server::Object;
use JOAP::Server;
use Error;

require Exporter;

our %EXPORT_TAGS = ( 'all' => [] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = ();

our $VERSION = $JOAP::VERSION;

JOAP::Server::Class->mk_classdata('Instances');
JOAP::Server::Class->mk_classdata('Superclasses');
JOAP::Server::Class->mk_classdata('Id');
JOAP::Server::Class->mk_classdata('IdFormat');
JOAP::Server::Class->mk_classdata('Separator');

JOAP::Server::Class->Instances({}); # Initially, no instances
JOAP::Server::Class->Superclasses([]);
JOAP::Server::Class->Separator (',');
JOAP::Server::Class->Id([]);
JOAP::Server::Class->IdFormat(undef);

# return the instance with the given instance ID

sub get {
    my $self = shift;

    return $self->Instances->{$_[0]};
}

# handle a JOAP  verb

sub on_add {

    my($self) = shift;
    my($iq) = shift;

    if (ref $self) {             # Can't call add on instances
        return $self->SUPER::on_add($iq);
    }

    my $respiq = $self->reply($iq);

    if (my($code, $text) = $self->_validate_add($iq)) {
	$respiq->SetType('error');
	$respiq->SetErrorCode($code);
	$respiq->SetError($text);
	return $respiq;
    }

    # this line is too long.

    my(%args) = map {($_->GetName, JOAP->decode($_->GetValue))} $iq->GetQuery->GetAttribute;

    my $id = $self->_make_id(%args);

    # Do we already have one of these?

    if ($self->get_instance($id)) {
	$respiq->SetType('error');
        $respiq->SetErrorCode(406); # not acceptable
        $respiq->SetError("An instance with this ID already exists.");
        return $respiq;
      }

    my $inst = $self->new(%args);

    $self->set_instance($inst->_id, $inst);

    # The address we should return is mostly in the $iq.

    my($jid) = $iq->GetTo('jid');
    $jid->SetResource($inst->_id);

    $respiq->GetQuery->SetNewAddress($jid->GetJID('full'));

    return $respiq;
}

# handle a JOAP  verb

sub on_edit {

    my $self = shift;
    my $pkg = ref($self) || $self;
    my $iq = shift;
    my $respiq = shift;
    my $oldid;

    # Save the old ID if this is an instance.

    if (ref($self)) {
        $oldid = $self->_id();
    }

    # Do the default editing schtuff

    $respiq = $self->SUPER::on_edit($iq);

    # If this is an instance, and the ID has changed, set the newaddress value

    if (ref($self)) {
	my $instid = $self->_id;

        if ($oldid ne $instid) {

	    $self->delete_instance($oldid);
	    $self->set_instance($instid, $self);

            my($jid) = $iq->GetTo('jid');
            $jid->SetResource($self->_id());
            $respiq->GetQuery->SetNewAddress($jid->GetJID('full'));
        }
    }

    return $respiq;
}

# handle a JOAP  verb

sub on_delete {
    my $self = shift;
    my $pkg = ref($self) || $self;
    my $iq = shift;
    my $respiq = $self->reply($iq);

    if (!ref($self)) {             # Can't call delete on a class
        return $self->SUPER::on_delete($iq);
    }

    $pkg->delete_instance($self->_id());

    # XXX: do we need to allow the instance a cleanup?

    return $respiq;
}

# handle a JOAP  verb

sub on_search {

    my($self) = shift;
    my($iq) = shift;

    if (ref($self)) {           # class method
        return $self->SUPER::on_search($iq);
    }

    my($respiq) = $self->reply($iq);

    if (my($code, $text) = $self->_validate_search($iq)) {
	$respiq->SetType('error');
	$respiq->SetErrorCode($code);
	$respiq->SetError($text);
	return $respiq;
    }

    # FIXME: This doesn't get instances of subclasses.
    # XXX: This is big, sloppy, dumb, and linear.

    my %match = map {($_->GetName, JOAP->decode($_->GetValue))} $iq->GetQuery->GetAttribute;

    # sneakily add

    my $addr = $iq->GetTo;

    my $resp = $respiq->GetQuery;

    $self->_iterate(sub
      {
          my $inst = $_;

          if (!%match || $inst->_match_all(%match)) {
	      # XXX: this assumes that the item is a direct instance
	      my $jid = new Net::Jabber::JID($addr);
	      $jid->SetResource($inst->_id);
              $resp->SetItem($jid->GetJID('full'));
          }
      });

    return $respiq;
}

# handle a JOAP  verb; we need to add our superclasses.

sub on_describe {

    my($self) = shift;
    my($iq) = shift;
    my($respiq) = $self->SUPER::on_describe($iq);

    if ($respiq->GetType() ne 'error') { # If that worked out OK...
	my $qry = $respiq->GetQuery;
        foreach my $class (@{$self->Superclasses}) {
            $qry->AddSuperclass($self->make_address(classname => $class));
        }
	$qry->SetTimestamp($self->timestamp);
    }

    return $respiq;
}

# validators

# these return a list of ($code, $text) if there's an error, or an
# empty list for success

# validate an incoming  request

sub _validate_edit {

    my $self = shift;
    my $reqiq = shift;

    if (my($code, $text) = $self->SUPER::_validate_edit($reqiq)) {
	return ($code, $text);
    }

    # You can set class variables through instances, but you can't set
    # instance variables through classes.

    if (!ref($self)) {
	my(@names) = map { $_->GetName } $reqiq->GetQuery->GetAttribute;

	my(@inst) = grep { $self->_attribute_allocation($_) ne 'class' } @names;

	if (@inst) {
	    return (406, join("\n", map "Can't edit instance variable $_ in class", @inst));
	}
    }

    # empty list indicates success

    return ();
}

# validate an incoming method

sub _validate_method {

    my $self = shift;
    my $reqiq = shift;

    if (my($code, $text) = $self->SUPER::_validate_method($reqiq)) {
	return ($code, $text);
    }

    # You can call class methods on instances, but not vice versa

    if (!ref($self)) {

	my $method = $reqiq->GetQuery->GetMethodCall->GetMethodName;

	if ($self->_method_allocation($method) ne 'class') {
	    return (406, join("\n", map "Can't call instance method $_ on class", $method));
	}
    }

    return ();
}

# validate an incoming  request

sub _validate_read {

    my $self = shift;
    my $reqiq = shift;

    if (my($code, $text) = $self->SUPER::_validate_read($reqiq)) {
	return ($code, $text);
    }

    # Check to see if they're trying to read an instance attribute from a class.

    if (!ref($self)) {
	my(@names) = $reqiq->GetQuery->GetName;

	if (@names) {
	    my(@inst) = grep { $self->_attribute_allocation($_) ne 'class' } @names;

	    if (@inst) {
		return (406, join("\n", map "Can't read instance variable $_ in class", @inst));
	    }
	}
    }

    return ();
}

# validate an incoming  request

sub _validate_add {
    my $self = shift;
    my $reqiq = shift;

    my @attrs = $self->_attribute_names;

    my @toset = $reqiq->GetQuery->GetAttribute;

    my @names = map {$_->GetName} @toset;

    # XXX: Move these checks to their own functions

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

    my @unknown = grep {my($a) = $_; ! grep {/$a/} @attrs} @names;

    if (@unknown) {
	return (406, join("\n", map {"No such attribute '$_'."} @unknown));
    }

    # Check for stuff that isn't writable.

    my @notallowed = grep { !$self->_attribute_writable($_) } @names;

    if (@notallowed) {
        return (406, join("\n", map {"Cannot edit attribute '$_'."} @notallowed));
    }

    # Are all required, writable attributes present?

    my @reqwrite = grep {$self->_attribute_required($_) && $self->_attribute_writable($_)} @attrs;

    my @unmatched = grep {my($a) = $_; ! grep {/$a/} @names} @reqwrite;

    if (@unmatched) {
	return (406, join("\n", map {"Required attribute '$_' not set."} @unknown));
    }

    # Are all attribute values acceptable?

    my @notok = grep {!$self->_attribute_ok($_->GetName, $_->GetValue)} @toset;

    if (@notok) {
	return (406, join("\n", map {"Value for attribute '" . $_->GetName . "' not acceptable."} @notok));
    }

    # empty list means "no probs"

    return ();
}

# validate an incoming  request

sub _validate_search {

    my $self = shift;
    my $reqiq = shift;

    my @attrs = $self->_attribute_names;

    my @match = $reqiq->GetQuery->GetAttribute;

    my @names = map {$_->GetName} @match;

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

    my @unknown = grep {my($a) = $_; ! grep {/$a/} @attrs} @names;

    if (@unknown) {
	return (406, join("\n", map {"No such attribute '$_'."} @unknown));
    }

    # Are there any class attributes in there?

    my @classattrs = grep {$self->_attribute_allocation($_) eq 'class'} @names;

    if (@classattrs) {
	return (406, join("\n", map {"Can't search on class attribute '$_'."} @classattrs));
    }

    # Are all attribute values acceptable?

    my @notok = grep {!$self->_attribute_match_ok($_->GetName, $_->GetValue)} @match;

    if (@notok) {
	return (406, join("\n", map {"Value for attribute '" . $_->GetName . "' not acceptable."} @notok));
    }

    # empty list means "no probs"

    return ();

}

# right now, just check the type

sub _attribute_match_ok {

    my $self = shift;
    my $name = shift;
    my $value = shift;
    my $type = $self->_attribute_type($name);

    return $self->_type_match($type, $value);
}

# matching semantics

sub _match_all {

    my $self = shift;
    my %match = @_;

    while (my($attr, $value) = each %match) {
	if (!$self->_match($attr, $value)) {
	  return 0;
	}
    }

    return 1;
}

# match a single attribute and value

sub _match {

    my $self = shift;
    my $attr = shift;
    my $match = shift;

    my $value = $self->_attribute_get($attr);
    my $type = $self->_attribute_type($attr);

    if ($type eq 'i4' || $type eq 'int' || $type eq 'double') {
	return $value == $match;
    }
    elsif ($type eq 'boolean') {
	return (($value && $match) || (!$value && !$match));
    }
    elsif ($type eq 'string') {
	return (index($value, $match) != -1);
    }
    elsif ($type eq 'dateTime.iso8601') {
	# XXX: it'd be nicer to use integer-compare here; maybe use dts at
	# ints internally?
	return $value eq $match;
    }
    elsif ($type eq 'struct') {
	# FIXME: make this work
	return 0;
    }
    elsif ($type eq 'array') {
	# FIXME: make this work
	return 0;
    }
}

# store an instance with the given instance ID

sub set_instance {

    my($self) = shift;
    my($pkg) = ref($self) || $self;
    my($instid) = shift;
    my $inst = shift;

    $pkg->Instances->{$instid} = $inst;
}

# get an instance with the given instance ID

sub get_instance {

    my($self) = shift;
    my($pkg) = ref($self) || $self;
    my($instid) = shift;

    return $pkg->Instances->{$instid};
}

# delete an instance with the given instance ID

sub delete_instance {

    my($self) = shift;
    my($pkg) = ref($self) || $self;
    my($instid) = shift;

    return delete $pkg->Instances->{$instid};
}

# Return the string value representing the instance ID

sub _id {

    my $self = shift;
    my $pkg = ref($self);

    my @ids = map {$self->_attribute_get($_)} @{$self->Id};

    return ($self->IdFormat) ?
      sprintf($self->IdFormat, @ids) :
        join($self->Separator, @ids);
}

# Return the string value representing the instance ID given a set of
# attributes

sub _make_id {
    my $self = shift;
    my %attrs = @_;

    my @ids = map {$attrs{$_}} @{$self->Id};

    return ($self->IdFormat) ?
      sprintf($self->IdFormat, @ids) :
        join($self->Separator, @ids);
}

# Iterate some code over all instances of this class

sub _iterate($\&) {

    my($self) = shift;
    my($block) = shift;

    while (my($id, $inst) = each %{$self->Instances}) {
        $_ = $inst;
        eval &$block;
    }
}

# used by _read; defines which attributes should be returned for a
#  verb with no arguments

sub _attribute_read_names {

    my $self = shift;
    my @names = $self->_attribute_names;

    if (ref($self)) {
	return grep { $self->_attribute_allocation($_) eq 'instance' } @names;
    }
    else {
	return grep { $self->_attribute_allocation($_) eq 'class' } @names;
    }
}

1;
__END__