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


line stmt bran cond sub pod time code
1             # JOAP::Proxy::Class.pm - class for classes that are classes
2             #
3             # Copyright (c) {$YEAR}, {$NAME} {$EMAIL}.
4             #
5             # This library is free software; you can redistribute it and/or
6             # modify it under the terms of the GNU Lesser General Public
7             # License as published by the Free Software Foundation; either
8             # version 2.1 of the License, or (at your option) any later version.
9             #
10             # This library is distributed in the hope that it will be useful,
11             # but WITHOUT ANY WARRANTY; without even the implied warranty of
12             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13             # Lesser General Public License for more details.
14             #
15             # You should have received a copy of the GNU Lesser General Public
16             # License along with this library; if not, write to the Free Software
17             # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18              
19             # tag: JOAP class proxy object class
20              
21             package JOAP::Proxy::Class;
22 1     1   2254 use JOAP::Proxy;
  0            
  0            
23             use JOAP::Proxy::Instance;
24             use base qw/JOAP::Proxy/;
25              
26             use 5.008;
27             use strict;
28             use warnings;
29              
30             our %EXPORT_TAGS = ( 'all' => [ qw// ] );
31             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
32             our @EXPORT = qw//;
33              
34             our $VERSION = $JOAP::VERSION;
35             our $AUTOLOAD;
36              
37             sub superclasses {
38             my $self = shift;
39             return (@_) ? $self->{_superclasses} = shift : $self->{_superclasses};
40             }
41              
42             sub _describe {
43             my $self = shift;
44             my $resp = $self->SUPER::_describe(@_);
45              
46             my @classes = $resp->GetQuery->GetSuperclass;
47             $self->superclasses(\@classes);
48              
49             return $resp;
50             }
51              
52             sub _default_edit_attrs {
53              
54             my $self = shift;
55              
56             # This _should_ return only writable attributes
57              
58             my $attrs = $self->SUPER::_default_edit_attrs;
59              
60             my @right_alloc = grep { $attrs->{$_}->{allocation} eq 'class' } keys %$attrs;
61              
62             # make that into a hash
63              
64             my %write = map {($_, $attrs->{$_})} @right_alloc;
65              
66             # return a reference to that hash
67              
68             return \%write;
69             }
70              
71             sub can {
72             my $self = shift;
73             my $name = shift;
74             my $func = $self->UNIVERSAL::can($name); # See if it's findable by standard lookup.
75              
76             if (!$func) { # if not, see if it's something we should make ourselves.
77             my $methdesc = $self->_method_descriptor($name);
78              
79             if ($methdesc && $methdesc->{allocation} eq 'class') {
80             $func = $self->_proxy_method($methdesc);
81             } else {
82             my $attrdesc = $self->_attribute_descriptor($name);
83             if ($attrdesc && $attrdesc->{allocation} eq 'class') {
84             $func = $self->_proxy_accessor($attrdesc);
85             }
86             }
87             }
88              
89             return $func;
90             }
91              
92             sub add {
93              
94             my $self = shift;
95              
96             my %args = @_;
97              
98             my $con = $self->Connection || throw JOAP::Proxy::Error::Local("Can't add without a connection.");
99              
100             # Servers will of course do these checks for us, because they need
101             # to preserve their data integrity. However, we save some time
102             # failing early if we know what the problem is.
103              
104             # check to see that all params are in our class
105              
106             my @unmatched = grep { !$self->_attribute_descriptor($_) } keys %args;
107              
108             if (@unmatched) {
109             throw JOAP::Proxy::Error::Local("Unknown attributes: " . join(",", @unmatched));
110             }
111              
112             # check to see that all params are writable
113              
114             my @unwritable = grep { ! $self->_attribute_descriptor($_)->{writable} } keys %args;
115              
116             if (@unwritable) {
117             throw JOAP::Proxy::Error::Local("Read-only attributes: " . join(",", @unwritable));
118             }
119              
120             # check to see that all params are instance
121              
122             my @noninst = grep { $self->_attribute_descriptor($_)->{allocation} ne 'instance' } keys %args;
123              
124             if (@noninst) {
125             throw JOAP::Proxy::Error::Local("Non-instance attributes: " . join(",", @noninst));
126             }
127              
128             my $attrdesc = $self->attributes;
129              
130             # check to see that all required, writable instance attrs are present
131              
132             my @reqwrite =
133             grep { my $desc = $attrdesc->{$_};
134             $desc->{required} &&
135             $desc->{writable} &&
136             ($desc->{allocation} eq 'instance')} keys %$attrdesc;
137              
138             my @unfulfill = grep { ! exists $args{$_} } @reqwrite;
139              
140             if (@unfulfill) {
141             throw JOAP::Proxy::Error::Local("Required, writable instance attributes not provided: " . join (",", @unfulfill));
142             }
143              
144             # Hooray! We're validated. Let's send the message already.
145              
146             my $iq = new Net::Jabber::IQ();
147             $iq->SetIQ(to => $self->address, type => 'set');
148              
149             my $add = $iq->NewQuery($JOAP::NS, 'add');
150              
151             while (my ($name, $arg) = each %args) {
152             my $attr = $add->AddAttribute(name => $name);
153             my $value = $attr->AddValue;
154             my $enc = JOAP->encode($self->_attribute_descriptor($name)->{type}, $arg);
155             JOAP->copy_value($enc, $value);
156             }
157              
158             my $resp = $con->SendAndReceiveWithID($iq);
159              
160             if ($resp->GetType eq 'error') {
161             throw JOAP::Proxy::Error::Remote($resp->GetError, $resp->GetErrorCode);
162             }
163              
164             my $addr = $resp->GetQuery->GetNewAddress;
165              
166             return $self->_get_instance($addr);
167             }
168              
169             # We want to be able to overload this in subclasses.
170              
171             sub _get_instance {
172              
173             my $self = shift;
174             my $addr = shift;
175              
176             # XXX: This is a little iffy, since it requires a round-trip to
177             # the server, even though we know some of the attributes. But a
178             # re-read is probably the safest thing.
179              
180             return JOAP::Proxy::Instance->get($addr,
181             methods => $self->methods,
182             attributes => $self->attributes,
183             superclasses => $self->superclasses,
184             description => $self->description,
185             timestamp => $self->timestamp);
186             }
187              
188             sub search {
189              
190             my $self = shift;
191              
192             my %args = @_;
193              
194             my $con = $self->Connection || throw JOAP::Proxy::Error::Local("Can't search without a connection.");
195              
196             # Servers will of course do these checks for us, because they need
197             # to preserve their data integrity. However, we save some time
198             # failing early if we know what the problem is.
199              
200             # Are there any attrs to search that aren't in our object?
201              
202             my @unknown = grep { !$self->_attribute_descriptor($_) } keys %args;
203              
204             if (@unknown) {
205             throw JOAP::Proxy::Error::Local("Unknown attributes: " . join(",", @unknown));
206             }
207              
208             # Are there any class attributes in there?
209              
210             my @classattrs = grep {$self->_attribute_descriptor($_)->{allocation} eq 'class'} keys %args;
211              
212             if (@classattrs) {
213             throw JOAP::Proxy::Error::Local("Can't search on class attributes: " . join(",", @classattrs));
214             }
215              
216             # Well, that's about all we can do.
217              
218             my $iq = new Net::Jabber::IQ();
219             $iq->SetIQ(to => $self->address, type => 'get');
220              
221             my $search = $iq->NewQuery($JOAP::NS, 'search');
222              
223             while (my ($name, $arg) = each %args) {
224             my $attr = $search->AddAttribute(name => $name);
225             my $value = $attr->AddValue;
226             my $enc = JOAP->encode($self->_attribute_descriptor($name)->{type}, $arg);
227             JOAP->copy_value($enc, $value);
228             }
229              
230             my $resp = $con->SendAndReceiveWithID($iq);
231              
232             if ($resp->GetType eq 'error') {
233             throw JOAP::Proxy::Error::Remote(value => $resp->GetErrorCode, text => $resp->GetError);
234             }
235              
236             # This is going to be a list of address strings
237              
238             my @items = $resp->GetQuery->GetItem;
239              
240             return @items;
241             }
242              
243             1; # don't forget to return a true value from the file
244              
245             __END__