File Coverage

blib/lib/JOAP/Proxy/Package/Class.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

# JOAP::Proxy::Package::Class -- Base package for JOAP Class classes
#
# 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 proxy class base class

use 5.008;
use strict;
use warnings;

package JOAP::Proxy::Package::Class;
use JOAP::Proxy::Package;
use JOAP::Proxy::Class;
use JOAP::Proxy::Instance;
use JOAP::Proxy::Error;
use Symbol;
use base qw/JOAP::Proxy::Package JOAP::Proxy::Class JOAP::Proxy::Instance/;

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

our $VERSION = $JOAP::VERSION;

JOAP::Proxy::Package::Class->mk_classdata('Address');
JOAP::Proxy::Package::Class->mk_classdata('Superclasses');

JOAP::Proxy::Package::Class->Address('');
JOAP::Proxy::Package::Class->Superclasses([]);

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

sub address {
    my $self = shift;
    if (!ref($self)) {
        return $self->Address(@_);
    } else {
        return $self->JOAP::Proxy::Instance::address(@_);
    }
}

sub add {

    my $self = shift;

    if (ref($self)) {
        throw JOAP::Proxy::Error::Local("Can't add to an instance.");
    } else {
        $self->SUPER::add(@_);
    }
}

# we meddle with this so we can return our own instance instead of a generic JOAP::Proxy::Instance

sub _get_instance {

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

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

sub search {

    my $self = shift;

    if (ref($self)) {
        throw JOAP::Proxy::Error::Local("Can't search an instance.");
    } else {
        $self->SUPER::search(@_);
    }
}

sub delete {

    my $self = shift;

    if (!ref($self)) {
        throw JOAP::Proxy::Error::Local("Can't call delete on a class.");
    } else {
        $self->SUPER::delete(@_);
    }
}

sub can {

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

    if (!defined($func)) { # if not, see if it's something we should make ourselves.
        if (my $methdesc = $self->_method_descriptor($name)) {
            if ($methdesc->{allocation} eq 'class') {
                $func = $self->_proxy_method($methdesc);
            } elsif (ref($self)) {
                $func = $self->_proxy_instance_method($methdesc);
            }
	} elsif (my $attrdesc = $self->_attribute_descriptor($name)) {
            if (ref($self) && $attrdesc->{allocation} ne 'class') {
                $func = $self->_proxy_instance_accessor($attrdesc);
            } elsif ($attrdesc->{allocation} eq 'class') {
                $func = $self->_proxy_class_accessor($attrdesc);
            }
        }
    }

    return $func;
}

# internal setter

sub _set {

    my $self = shift;
    my $name = shift;
    my $value = shift;
    my $allocation = $self->_attribute_descriptor($name)->{allocation};

    if ($allocation eq 'class') {
        my $pkg = ref($self) || $self;
        my $globref = qualify_to_ref($pkg . "::" . $name);
        my $sref = *$globref{SCALAR};
        $$sref = $value;
    } elsif (ref($self)) {
        $self->{$name} = $value;
    }
}

sub _describe {

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

    my @supers = $describe->GetSuperclass;

    $self->Superclasses(\@supers);

    return $resp;
}

# We need to overload this to get only instance or class attributes,
# depending on the type of self.

sub _default_edit_attrs {

    my $self = shift;

    if (ref($self)) {
        return $self->JOAP::Proxy::Instance::_default_edit_attrs;
    } else {
        return $self->JOAP::Proxy::Class::_default_edit_attrs;
    }
}

sub _proxy_instance_accessor {

    my $self = shift;
    my $descriptor = shift;

    my $name = $descriptor->{name};
    my $writable = $descriptor->{writable};
    my $type = $descriptor->{type};

    my $acc = $self->JOAP::Proxy::Instance::_proxy_accessor($descriptor);

    my $func = sub {
        my $self = shift;
        if (!ref($self)) {
            throw JOAP::Proxy::Error::Local("Can't use instance accessor on a class.");
        }
        return $self->$acc(@_);
    };

    return $func;
}

sub _proxy_instance_method {

    my $self = shift;
    my $descriptor = shift;

    my $meth = $self->JOAP::Proxy::Instance::_proxy_method($descriptor);

    my $func = sub {
        my $self = shift;
        if (!ref($self)) {
            throw JOAP::Proxy::Error::Local("Can't use instance method on a class.");
        }
        return $self->$meth(@_);
    };

    return $func;
}

sub _proxy_class_accessor {

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

    my $name = $descriptor->{name};
    my $writable = $descriptor->{writable};
    my $type = $descriptor->{type};

    my $globref = qualify_to_ref($pkg . "::" . $name);
    my $sref = *$globref{SCALAR};

    my $func = undef;

    # This is kind of wordy, but we need to unwrap the $writable
    # stuff at compile time rather than run time.

    # XXX: choose a coercion function at compile-time

    if ($writable) {
        $func = sub {
            my($self) = shift;
            return (@_) ? $$sref = JOAP->coerce($type, @_) : $$sref;
        };
    } else {
        $func = sub {
            my($self) = shift;
            throw JOAP::Proxy::Error::Local("Read-only attribute $name") if @_;
            return $$sref;
        };
    }

    return $func;
}

sub instance_method {
    my $self = shift;
    my $name = shift;

    my $desc = $self->_method_descriptor($name);
    my $method = $self->_proxy_instance_method($desc);
}

sub class_method {
    my $self = shift;
    my $name = shift;

    my $desc = $self->_method_descriptor($name);
    my $method = $self->_proxy_method($desc);
}

sub instance_accessor {
    my $self = shift;
    my $name = shift;

    my $desc = $self->_attribute_descriptor($name);
    my $accessor = $self->_proxy_instance_accessor($desc);
}

sub class_accessor {
    my $self = shift;
    my $name = shift;

    my $desc = $self->_attribute_descriptor($name);
    my $accessor = $self->_proxy_class_accessor($desc);
}

1;  # the loneliest number

__END__