File Coverage

blib/lib/JOAP.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

# JOAP - Perl Extension for the Jabber Object Access Protocol
#
# 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 main module

package JOAP;
use base qw/Exporter/;

use 5.008;
use strict;
use warnings;

BEGIN {
    use Net::Jabber::Protocol;

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

    our $VERSION = '0.01';
    our $NS = 'http://www.jabber.org/jeps/jep-0075.html#0.3';

    my %spaces =
      ($JOAP::NS =>
       [{name=>'Read',
         type=>'master'},
        {name=>'Edit',
         type=>'master'},
        {name=>'Add',
         type=>'master'},
        {name=>'Delete',
         type=>'master'},
        {name=>'Search',
         type=>'master'},
        {name=>'Describe',
         type=>'master'},
        {name=>'Name',          # read req
         type=>'array',
         path=>'name/text()'},
        {name=>'Attribute',     # read resp, edit/add/search req
         type=>'children',
         path=>'attribute',
         child=>['Query', '__netjabber__:' . $JOAP::NS . ':attribute'],
         calls=>['Get', 'Defined', 'Add']},
        {name=>'Timestamp',
         path=>'timestamp/text()'}, # read/describe resp
        {name=>'NewAddress',    # add/edit resp
         path=>'newAddress/text()'},
        {name=>'Item',          # search resp
         type=>'array',
         path=>'item/text()'},
        {name=>'Desc',          # describe resp
         type=>'array',
         path=>'desc/text()'},
        {name=>'Class',         # describe resp
         type=>'array',
         path=>'class/text()'},
        {name=>'Superclass',    # describe resp
         type=>'array',
         path=>'superclass/text()'},
        {name=>'AttributeDescription', # describe resp
         type=>'children',
         path=>'attributeDescription',
         child=>['Query', '__netjabber__:' . $JOAP::NS . ':attributeDescription'],
         calls=>['Get', 'Defined', 'Add']},
        {name=>'MethodDescription', # describe resp
         type=>'children',
         path=>'methodDescription',
         child=>['Query', '__netjabber__:' . $JOAP::NS . ':methodDescription'],
         calls=>['Get', 'Defined', 'Add']}],

       '__netjabber__:' . $JOAP::NS . ':attribute' =>
       [{name=>'Attribute',
         type=>'master'},
        {name=>'Name',
         path=>'name/text()'},
        {name=>'Value',
         path=>'value',
         type=>'children',
         child=>['Query', '__netjabber__:iq:rpc:value'],
         calls=>['Get', 'Add', 'Defined']},
        {name=>'RPCValue',
         path=>'value',
         type=>'children',
         child=>['Query', '__netjabber__:iq:rpc:value'],
         calls=>['Get', 'Add', 'Defined']}],

       '__netjabber__:' . $JOAP::NS . ':attributeDescription' =>
       [{name=>'AttributeDescription',
         type=>'master'},
        {name=>'Name',
         path=>'name/text()'},
        {name=>'Type',
         path=>'type/text()'},
        {name=>'Desc',
         type=>'array',
         path=>'desc/text()'},
        {name=>'Required',
         path=>'@required'},
        {name=>'Writable',
         path=>'@writable'},
        {name=>'Allocation',
         path=>'@allocation'}],

       '__netjabber__:' . $JOAP::NS . ':methodDescription' =>
       [{name=>'MethodDescription',
         type=>'master'},
        {name=>'Name',
         path=>'name/text()'},
        {name=>'ReturnType',
         path=>'returnType/text()'},
        {name=>'Desc',
         path=>'desc/text()'},
        {name=>'Params',
         path=>'params',
         type=>'children',
         child=>['Query', '__netjabber__:' . $JOAP::NS . ':params'],
         calls=>['Get','Defined','Add']},
        {name=>'Allocation',
         path=>'@allocation'}],

       '__netjabber__:' . $JOAP::NS . ':params' =>
       [{name=>'Params',
         path=>'param',
         type=>'children',
         child=>['Query', '__netjabber__:' . $JOAP::NS . ':param'],
         calls=>['Get', 'Defined']},
        {name=>'Param',
         path=>'param',
         type=>'node',
         child=>['Query', '__netjabber__:' . $JOAP::NS . ':param'],
         calls=>['Add']}],

       '__netjabber__:' . $JOAP::NS . ':param' =>
       [{name=>'Param',
         type=>'master'},
        {name=>'Name',
         path=>'name/text()'},
        {name=>'Type',
         path=>'type/text()'},
        {name=>'Desc',
         path=>'desc/text()'}]
      );

    my ($ns, $funcs);

    while (($ns, $funcs) = each %spaces) {

        # XXX: This is stupid. Trying to fake out the OO syntax, we're
        # gonna get bit.

        Net::Jabber::Protocol->DefineNamespace(undef,
                                               xmlns=>$ns,
                                               type=>'Query',
                                               functions=>$funcs);
    }

    %spaces = ();
}

# A regular expression for XML Schema dateTime stuff

my $dt = '^(-?\d{4,})-(\d{2})-(\d{2})T(\d{2}):(\d{2}):(\d{2})(\.\d+)?(Z|[+-]\d{2}:\d{2})?$';

# utilities to encode datur

sub encode {

    my $self = shift;
    my $type = shift;
    my $value = shift;

    if (!$type) {
        $type = $self->guess_type($value);
    }

    my $jval = new Net::Jabber::Query('value');
    $jval->SetXMLNS('__netjabber__:iq:rpc:value');

    my $realvalue = JOAP->coerce($type, $value);

    if ($type eq 'int' || $type eq 'i4') {
        $jval->SetI4($realvalue);
    } elsif ($type eq 'boolean') {
        $jval->SetBoolean($realvalue);
    } elsif ($type eq 'dateTime.iso8601') {
        $jval->SetDateTime($realvalue); # XXX: deal with numbers, arrays, Date::* objects, etc
    } elsif ($type eq 'double') {
        $jval->SetDouble($realvalue);
    } elsif ($type eq 'string') {
        $jval->SetString($realvalue);
    } elsif ($type eq 'array') {
        my $arr = $jval->AddArray();
        my $do = $arr->AddData();

        foreach my $data (@$value) {
            $do->AddValue($self->guess_type($data) => $data);
        }
    } elsif ($type eq 'struct') {
        my $str = $jval->AddStruct();
        my $name;
        my $val;

        while (($name, $val) = each %$value) {
            $str->AddMember(name => $name)->AddValue($self->guess_type($val) => $val);
        }
    }
    else {
        throw Error::Simple("Unknown type: $type\n");
    }

    return $jval;
}

sub guess_type {

    my($self) = shift;
    my($value) = shift;
    my($type);

    if ($value =~ /^[+-]?\d+$/) {
        $type = 'i4';
    } elsif ($value =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/) {
        $type = 'double';
    } elsif ($value =~ /$dt/) {
        $type = 'dateTime.iso8601';
    } else {
        $type = 'string';
    }

    return $type;
}

sub decode {

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

    if ($jval->DefinedI4()) {
        return $jval->GetI4() + 0;
    } elsif ($jval->DefinedDouble()) {
        return $jval->GetDouble() + 0.0;
    } elsif ($jval->DefinedDateTime()) {
        return $jval->GetDateTime();
    } elsif ($jval->DefinedBoolean()) {
        return ($jval->GetBoolean()) ? 1 : 0;
    } elsif ($jval->DefinedString()) {
        return $jval->GetString();
    } elsif ($jval->DefinedStruct()) {
        my $results = {};
        foreach my $member ($jval->GetStruct->GetMembers()) {
            $results->{$member->GetName} = $self->decode($member->GetValue);
        }
        return $results;
    } elsif ($jval->DefinedArray()) {
        my $results = [];
        foreach my $value ($jval->GetArray()->GetDatas()->GetValue()) {
            push @$results, $self->decode($value);
        }
        return $results;
    }
}

sub copy_value {

    my $self = shift;
    my $from = shift;
    my $to = shift;

    if ($from->DefinedI4()) {
        $to->SetI4($from->GetI4() + 0);
    } elsif ($from->DefinedDouble()) {
        $to->SetDouble($from->GetDouble() + 0.0);
    } elsif ($from->DefinedDateTime()) {
        $to->SetDateTime($from->GetDateTime());
    } elsif ($from->DefinedBoolean()) {
        $to->SetBoolean(($from->GetBoolean()) ? 1 : 0);
    } elsif ($from->DefinedString()) {
        $to->SetString($from->GetString());
    } elsif ($from->DefinedStruct()) {
	my $str = $to->AddStruct;
        foreach my $member ($from->GetStruct->GetMembers()) {
	    my $v = $str->AddMember(name => $member->GetName)->AddValue;
	    $self->copy_value($member->GetValue, $v);
        }
    } elsif ($from->DefinedArray()) {
	my $arr = $to->AddArray;
	my $d = $arr->AddData;
        foreach my $value ($from->GetArray()->GetDatas()->GetValue()) {
	    my $v = $d->AddValue;
	    $self->copy_value($value, $v);
        }
    }
}

sub value_type {

    my $self = shift;
    my $value = shift;

    if ($value->DefinedI4) {
	return 'i4';
    }
    elsif ($value->DefinedBoolean) {
	return 'boolean';
    }
    elsif ($value->DefinedString) {
	return 'string';
    }
    elsif ($value->DefinedDouble) {
	return 'double';
    }
    elsif ($value->DefinedDateTime) {
	return 'dateTime.iso8601';
    }
    elsif ($value->DefinedStruct) {
	return 'struct';
    }
    elsif ($value->DefinedBase64) {
	return 'base64';
    }
    elsif ($value->DefinedArray) {
	return 'array';
    }
}

# coerce a perl value into the right shape for the given type

sub coerce {

    my($self) = shift;
    my($type) = shift;
    my $value = shift;

    if ($type eq 'string') {
        return (defined $value) ? $value . '' : '';
    } elsif ($type eq 'int' || $type eq 'i4') {
        no warnings;            # turn off non-numeric warnings
        return (defined $value) ? ($value + 0) : 0;
    } elsif ($type eq 'double') {
        no warnings;            # turn off non-numeric warnings
        return (defined $value) ? ($value + 0.0) : 0.0;
    } elsif ($type eq 'boolean') {
        return ($value) ? 1 : 0;
    } elsif ($type eq 'array') {
        return (defined $value) ? $value : [];
    } elsif ($type eq 'struct') {
        return (defined $value) ? $value : {};
    } elsif ($type eq 'base64') {
        return $value;          # FIXME: base64 the thing
    } elsif ($type eq 'dateTime.iso8601') {
        my $default = '0001-00-00T00:00:00Z';
        if (!defined($value)) {
            return $default;
        } elsif (ref($value) eq "ARRAY") {
            if (scalar(@$value) >= 6) { # looks more or less like a gmtime thingy
                return $self->array_to_datetime($value);
            } else {
                return $default;
            }
        } elsif (ref($value)) { # we don't know what to do with other refs
            return $default;
        } elsif ($value =~ /$dt/) {
            return $value;
        } elsif ($value =~ /^\d+/) { # looks like an int
            return $self->int_to_datetime($value);
        } else {
            return $default;
        }
    } else {
        throw Error::Simple("Unknown type: $type");
    }
}

sub int_to_datetime {
    my $self = shift;
    my $val = shift;
    my $int = $self->coerce('i4', $val);

    return $self->array_to_datetime([gmtime($int)]);
}

sub array_to_datetime {

    my $self = shift;
    my $arr = shift;

    return sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ", $arr->[5] + 1900,
                   $arr->[4] + 1, $arr->[3], $arr->[2], $arr->[1],
                   $arr->[0]);
}

# converts a datetime string to a gmtime-style array

sub datetime_to_array {

    my $self = shift;
    my $in = shift;

    my @parts = $in =~ /$dt/;

    if (!@parts) {
        return ();
    } else {
        return ($parts[5], $parts[4], $parts[3],
                $parts[2], $parts[1] - 1, $parts[0] - 1900);
    }
}

1;

__END__