JOAP::Server::Class - Base Class for JOAP Server-Side Classes and Instances

JOAP documentation Contained in the JOAP distribution.

Index

Code Index:

NAME

Top

JOAP::Server::Class - Base Class for JOAP Server-Side Classes and Instances

SYNOPSIS

Top

    package MyPerson;
    use base qw(JOAP::Server::Class);
    use Error;

    # define class description

    MyPerson->Description(<<'END_OF_DESCRIPTION');
    Basic info on a person.
    END_OF_DESCRIPTION

    # define class attributes

    MyPerson->Attributes (
        {
            given_name => {
                type => 'string',
                required => 1,
                desc => 'Given name of the person.'
            },

            family_name => {
                type => 'string',
                required => 1,
                desc => 'Family name of the person.'
            },

            birthdate => {
                type => 'dateTime.iso8601',
                required => 1,
                desc => 'birthdate of person in GMT'
            },

            age => {
                type => 'i4',
                writable => 0,
                desc => 'Age in years (rounded down) of person at current time',
            },

            species => {
                type => 'string',
                writable => 0,
                allocation => 'class',
                desc => 'species of people'
            },
        });

    # specify methods

    MyPerson->Methods (
        {
            walk => {
                returnType => 'boolean',
                params => [
                    {
                        name => 'steps',
                          type => 'i4',
                          desc => 'how many steps forward to walk, fault if less than zero'
                    }
                ],
                desc => 'Walk forward \'steps\' steps'},
        });

    # specify the class ID

    MyPerson->Id(['family_name', 'given_name']);

    # specify class variables

    our $species = 'homo sapiens';

    # an accessor for an attribute

    sub age {

        my $self = shift;
        my $bd = $self->birthdate;
        my @now = gmtime;

        my @then = JOAP->datetime_to_array($bd);

        my ($y, $m, $d) = ($then[5], $then[4], $then[3]);

        my $age = $now[5] - $y;

        if (($now[4] > $m) ||
            ($now[4] == $m && $now[3] >= $d))
        {
            $age++;
        }

        return $age;
    }

    # an instance method

    sub walk {

        my $self = shift;
        my $steps = shift;

        if ($steps < 0) {
            throw Error::Simple("Never go back.", 5440);
        }

        for (my $i = 0; $i < $steps; $i++) {
            $self->step();
        }

        return 1;
    }

    1;                          # gotta return 1

ABSTRACT

Top

This is an abstract superclass for creating Perl classes that are servable through JOAP.

DESCRIPTION

Top

Well, I haven't been looking forward to writing this POD, but here we go.

JOAP::Server::Class is the pulsing heart of the JOAP server-side universe. You use it to create your own JOAP-servable classes, and things should just work.

The key part of this framework is that you define your class's structure -- its attributes, methods, and superclasses -- using class mutators in your class module. The server framework uses this structural definition to expose your class to the Jabber network, and handles all JOAP and XML-RPC messages for you. It routes requests for attributes and methods to the appropriate part of your class automatically, and it will create data, and methods, in the right places if you just leave everything at the defaults.

The basic model is that your Perl class becomes a JOAP class, and each Perl instance becomes a JOAP instance. Instance data is stored in the instance, and class data is stored in the class. It's pretty simple.

There's also an interface that's exposed to object servers; it's not documented here (yet).

Class Methods

This section discusses the class methods you need to call to define your class. Usually you just call them straight from the class module, as shown above in the synopsis.

Description($string)

Sets the human-readable description of the class.

Attributes($hashref)

This sets the publicly available attributes for the class. $hashref is a reference to a hashtable mapping attribute names to attribute descriptors. See JOAP::Descriptors for the format of this data structure.

Besides the fields listed there, the attribute descriptor can also contain the following fields:

getter

This is the name of, or a reference to, a method that returns the value of the attribute. If no getter is defined, the method in this package with the same name as the attribute is used. If no such method is defined, an autoloaded method is defined at runtime (see Autoloaded Accessors below for details).

setter

This is the name of, or a reference to, a method that sets the value of the attribute. If no setter is defined, the method in this package with the same name as the attribute is used. If no such method is defined, an autoloaded method is defined at runtime (see Autoloaded Accessors below for details).

accessor

This is the name of, or a reference to, a method that acts as both 'getter' and 'setter'.

Methods($hashref)

This sets the publicly available methods for the class. $hashref is a reference to a hashtable mapping method names to method descriptors; see JOAP::Descriptors for the format of method descriptors.

As well as the fields described normally for method descriptors, the following fields are also used:

function

This is the name of, or reference to, a function that acts as this method. If the field is not provided, the function with the same name in this package will be used.

Superclasses($arrayref)

This sets the visible superclasses for the class. $arrayref is a reference to an array of strings containing the JOAP addresses of all superclasses of the class. See JOAP::Addresses for the format of JOAP addresses.

Id($arrayref)

This sets the attributes that will be used to construct instance IDs for instances of this class. $arrayref is a reference to an array of attribute names. The IDs will be used in the order defined.

If IdFormat (see below) is defined, that printf-style format string will be used to construct the instance of the object, with the values of the listed attributes as parameters. Otherwise, a string will be constructed joining the values of each attribute with the separator defined by Separator (see below).

The combination of the attributes used in the Id array should be sufficient to uniquely identify an instance.

IdFormat($fmt)

Sets the string used for formatting the instance IDs. This is a printf in perlfunc format string. The value of each attribute in the array will be given, in order, as parameters.

Note that support for this feature is spotty right now; using Separator below is your safest bet for the near future.

Separator($sep)

Sets the string used to separate attributes in the instance ID. Defaults to ',', but you may want to set it to another value for classes where, say, a comma may appear in the attribute data.

Container Interface

This class also has an interface that containers can use to retrieve instances of the class.

Package->get($instid)

This method returns the instance object that has the given instance ID, or undef if no such instance exists.

Storage Interface

By default, instances are stored in memory in a hashtable that maps instance IDs to the instances themselves. This is pretty losey, doesn't persist the instances through program invocations, and could stand a lot of work. The interface used internally by JOAP::Server::Class to retrieve instances looks like this:

Package->get_instance($instid)

Returns the instance that has instance ID $instid, or undef if such an instance doesn't exist.

Package->set_instance($instid, $inst)

Maps the instance $inst to instance ID $instid.

Package->delete_instance($instid)

Removes the instance with instance ID $instid from the storage map.

Autoloaded Accessors

If a getter or setter is not defined for an attribute named in the Attributes map, the JOAP server libraries try to use a function by the same name as a Perl method to retrieve or set the attribute. You can use this for attributes that are calculated from the values of other attributes, like the age attribute in the synopsis above.

If no Perl method by the same name is defined, the library creates a method to act as an accessor. This happens when the attribute is first used.

The default autoloaded accessor for instance attributes will store the attribute value as a field in the instance. For class attributes, the value will be stored as a symbol in the class package. The $species attribute in the synopsis is an example of a class attribute in the package's namespace.

It's generally better practice to use accessors for attributes in your custom code, rather than using the instance fields or class variables directly.

Custom Accessors

As mentioned above, you can define custom accessors if simple data storage is not sufficient, or if you need to define side-effects from setting or getting an attribute. (For example, the synopsis above shows an age attribute defined with a custom accessor that calculates the value from the birthdate attribute. An alternative would be a custom accessor for birthdate that calculates and sets the value of age whenever birthdate is updated.)

Accessors will be called like:

    $self->accessor($value)

...for setting the value, and:

    $value = $self->accessor

...for getting the value. $self will be an instance of the class for attributes with allocation 'instance', and the class itself for attributes with allocation 'class'.

Accessors will never be called to set the value of an attribute if that attribute has its writable flag set to 0.

Custom Methods

If your class exposes methods for public use, you need to define custom code for those methods. Your method will be called like:

    $return_value = $self->method($param1, $param2, ...)

Here, $self is either an instance of this class, if the method allocation is 'instance', or the class itself, if the method allocation is 'class'. The parameters will be the parameters defined in the params field, in order.

Your method will never be called with parameters of the wrong type, or with the wrong number of parameters. That's handled at the library level.

As mentioned above, for each method, you can either define an eponymous method in the package, or you can use the function field of the method descriptor to map another function in as the method.

If there are problems with your method, you can throw an Error exception as defined in Error. The value and text of the Error will be mapped to the faultCode and faultString in the resulting XML-RPC fault.

Data Marshalling

In your custom code, you shouldn't normally have to worry about JOAP's funky data types in your custom code. All parameters and attribute values your code receives as input will already have been marshalled to native Perl types. You can return values as Perl types, and they'll be marshalled to the correct JOAP data type.

Some caveats, though:

array

Arrays are handled by reference. You should return references to arrays as return values, and you'll receive references to arrays as input.

struct

Structs are marshalled to hash references. You should return references to hashes as return values, and you'll receive references to hashes as input.

dateTime.iso8601

These values are not marshalled into any native Perl type, since there's not really a good native type to marshall them into. Instead, they come in as ISO 8601 formatted strings. You can use the JOAP-datetime_to_array> method to convert this to an array like the one returned by gmtime in perlfunc. You can return references to gmtime-like arrays, or just integers in seconds-since-the-epoch format (as returned by time in perfunc), or as formatted strings.

EXPORT

None by default.

BUGS

Top

This documentation is woefully insufficient.

There's currently no persistence built in to this class, and there's no documentation on how to implement your own persistence (although it's possible).

There's no documentation on how to build on-the-fly classes that act as a gateway to non-JOAP object systems.

SEE ALSO

Top

See JOAP for general information about JOAP as well as contact information for the author.

See Error for how to throw Error exceptions.

See JOAP::Server::Object for a bit more information about how this class works.

See JOAP::Server for defining object servers.

AUTHOR

Top

Evan Prodromou, <evan@prodromou.san-francisco.ca.us>

COPYRIGHT AND LICENSE

Top

Copyright (c) 2003, Evan Prodromou <evan@prodromou.san-francisco.ca.us>

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

JOAP documentation Contained in the JOAP distribution. 
# JOAP::Server::Class -- Base Class for JOAP Server-Side Classes and Instances
#
# Copyright (c) 2003, Evan Prodromou <evan@prodromou.san-francisco.ca.us>
#
# 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 <add> 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 <edit> 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 <delete> 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 <search> 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 <describe> 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 <edit> 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 <read> 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 <add> 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 <search> 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
# <read> 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__