CPANPLUS

 view release on metacpan or  search on metacpan

inc/bundle/Object/Accessor.pm  view on Meta::CPAN

package Object::Accessor;
use if $] > 5.017, 'deprecate';

use strict;
use Carp            qw[carp croak];
use vars            qw[$FATAL $DEBUG $AUTOLOAD $VERSION];
use Params::Check   qw[allow];

### some objects might have overload enabled, we'll need to
### disable string overloading for callbacks
require overload;

$VERSION    = '0.48';
$FATAL      = 0;
$DEBUG      = 0;

use constant VALUE => 0;    # array index in the hash value
use constant ALLOW => 1;    # array index in the hash value
use constant ALIAS => 2;    # array index in the hash value

=head1 NAME

Object::Accessor - interface to create per object accessors

=head1 SYNOPSIS

    ### using the object
    $obj = Object::Accessor->new;        # create object
    $obj = Object::Accessor->new(@list); # create object with accessors
    $obj = Object::Accessor->new(\%h);   # create object with accessors
                                         # and their allow handlers

    $bool   = $obj->mk_accessors('foo'); # create accessors
    $bool   = $obj->mk_accessors(        # create accessors with input
               {foo => ALLOW_HANDLER} ); # validation

    $bool   = $obj->mk_aliases(          # create an alias to an existing
                alias_name => 'method'); # method name

    $clone  = $obj->mk_clone;            # create a clone of original
                                         # object without data
    $bool   = $obj->mk_flush;            # clean out all data

    @list   = $obj->ls_accessors;        # retrieves a list of all
                                         # accessors for this object

    $bar    = $obj->foo('bar');          # set 'foo' to 'bar'
    $bar    = $obj->foo();               # retrieve 'bar' again

    $sub    = $obj->can('foo');          # retrieve coderef for
                                         # 'foo' accessor
    $bar    = $sub->('bar');             # set 'foo' via coderef
    $bar    = $sub->();                  # retrieve 'bar' by coderef

    ### using the object as base class
    package My::Class;
    use base 'Object::Accessor';

    $obj    = My::Class->new;               # create base object
    $bool   = $obj->mk_accessors('foo');    # create accessors, etc...

    ### make all attempted access to non-existent accessors fatal
    ### (defaults to false)
    $Object::Accessor::FATAL = 1;

    ### enable debugging
    $Object::Accessor::DEBUG = 1;

    ### advanced usage -- callbacks
    {   my $obj = Object::Accessor->new('foo');
        $obj->register_callback( sub { ... } );

        $obj->foo( 1 ); # these calls invoke the callback you registered
        $obj->foo()     # which allows you to change the get/set
                        # behaviour and what is returned to the caller.
    }

    ### advanced usage -- lvalue attributes
    {   my $obj = Object::Accessor::Lvalue->new('foo');
        print $obj->foo = 1;            # will print 1
    }

    ### advanced usage -- scoped attribute values
    {   my $obj = Object::Accessor->new('foo');

        $obj->foo( 1 );
        print $obj->foo;                # will print 1

        ### bind the scope of the value of attribute 'foo'
        ### to the scope of '$x' -- when $x goes out of
        ### scope, 'foo's previous value will be restored
        {   $obj->foo( 2 => \my $x );
            print $obj->foo, ' ', $x;   # will print '2 2'
        }
        print $obj->foo;                # will print 1
    }


=head1 DESCRIPTION

C<Object::Accessor> provides an interface to create per object
accessors (as opposed to per C<Class> accessors, as, for example,
C<Class::Accessor> provides).

You can choose to either subclass this module, and thus using its
accessors on your own module, or to store an C<Object::Accessor>
object inside your own object, and access the accessors from there.
See the C<SYNOPSIS> for examples.

=head1 METHODS

=head2 $object = Object::Accessor->new( [ARGS] );

Creates a new (and empty) C<Object::Accessor> object. This method is
inheritable.

Any arguments given to C<new> are passed straight to C<mk_accessors>.

If you want to be able to assign to your accessors as if they
were C<lvalue>s, you should create your object in the
C<Object::Accessor::Lvalue> namespace instead. See the section
on C<LVALUE ACCESSORS> below.

=cut

sub new {
    my $class   = shift;
    my $obj     = bless {}, $class;

inc/bundle/Object/Accessor.pm  view on Meta::CPAN

  $self->mk_accessors('foo');
  $self->mk_aliases( bar => 'foo' );

  $self->bar( 42 );
  print $self->foo;     # will print 42

=cut

sub mk_aliases {
    my $self    = shift;
    my %aliases = @_;

    while( my($alias, $method) = each %aliases ) {

        ### already created apparently
        if( exists $self->{$alias} ) {
            __PACKAGE__->___debug( "Accessor '$alias' already exists");
            next;
        }

        $self->___alias( $alias => $method );
    }

    return 1;
}

=head2 $clone = $self->mk_clone;

Makes a clone of the current object, which will have the exact same
accessors as the current object, but without the data stored in them.

=cut

### XXX this creates an object WITH allow handlers at all times.
### even if the original didn't
sub mk_clone {
    my $self    = $_[0];
    my $class   = ref $self;

    my $clone   = $class->new;

    ### split out accessors with and without allow handlers, so we
    ### don't install dummy allow handlers (which makes O::A::lvalue
    ### warn for example)
    my %hash; my @list;
    for my $acc ( $self->ls_accessors ) {
        my $allow = $self->{$acc}->[ALLOW];
        $allow ? $hash{$acc} = $allow : push @list, $acc;

        ### is this an alias?
        if( my $org = $self->{ $acc }->[ ALIAS ] ) {
            $clone->___alias( $acc => $org );
        }
    }

    ### copy the accessors from $self to $clone
    $clone->mk_accessors( \%hash ) if %hash;
    $clone->mk_accessors( @list  ) if @list;

    ### copy callbacks
    #$clone->{"$clone"} = $self->{"$self"} if $self->{"$self"};
    $clone->___callback( $self->___callback );

    return $clone;
}

=head2 $bool = $self->mk_flush;

Flushes all the data from the current object; all accessors will be
set back to their default state of C<undef>.

Returns true on success and false on failure.

=cut

sub mk_flush {
    my $self = $_[0];

    # set each accessor's data to undef
    $self->{$_}->[VALUE] = undef for $self->ls_accessors;

    return 1;
}

=head2 $bool = $self->mk_verify;

Checks if all values in the current object are in accordance with their
own allow handler. Specifically useful to check if an empty initialised
object has been filled with values satisfying their own allow criteria.

=cut

sub mk_verify {
    my $self = $_[0];

    my $fail;
    for my $name ( $self->ls_accessors ) {
        unless( allow( $self->$name, $self->ls_allow( $name ) ) ) {
            my $val = defined $self->$name ? $self->$name : '<undef>';

            __PACKAGE__->___error("'$name' ($val) is invalid");
            $fail++;
        }
    }

    return if $fail;
    return 1;
}

=head2 $bool = $self->register_callback( sub { ... } );

This method allows you to register a callback, that is invoked
every time an accessor is called. This allows you to munge input
data, access external data stores, etc.

You are free to return whatever you wish. On a C<set> call, the
data is even stored in the object.

Below is an example of the use of a callback.

inc/bundle/Object/Accessor.pm  view on Meta::CPAN

        if ( not exists $self->{$method} ) {
            __PACKAGE__->___error("No such accessor '$method'", 1);
            return;
        }

    ### a method on something else, die with a descriptive error;
    } else {
        local $FATAL = 1;
        __PACKAGE__->___error(
                "You called '$AUTOLOAD' on '$self' which was interpreted by ".
                __PACKAGE__ . " as an object call. Did you mean to include ".
                "'$method' from somewhere else?", 1 );
    }

    ### is this is an alias, redispatch to the original method
    if( my $original = $self->{ $method }->[ALIAS] ) {
        return $self->___autoload( $original, @_ );
    }

    ### assign?
    my $val = $assign ? shift(@_) : $self->___get( $method );

    if( $assign ) {

        ### any binding?
        if( $_[0] ) {
            if( ref $_[0] and UNIVERSAL::isa( $_[0], 'SCALAR' ) ) {

                ### tie the reference, so we get an object and
                ### we can use it's going out of scope to restore
                ### the old value
                my $cur = $self->{$method}->[VALUE];

                tie ${$_[0]}, __PACKAGE__ . '::TIE',
                        sub { $self->$method( $cur ) };

                ${$_[0]} = $val;

            } else {
                __PACKAGE__->___error(
                    "Can not bind '$method' to anything but a SCALAR", 1
                );
            }
        }

        ### need to check the value?
        if( defined $self->{$method}->[ALLOW] ) {

            ### double assignment due to 'used only once' warnings
            local $Params::Check::VERBOSE = 0;
            local $Params::Check::VERBOSE = 0;

            allow( $val, $self->{$method}->[ALLOW] ) or (
                __PACKAGE__->___error(
                    "'$val' is an invalid value for '$method'", 1),
                return
            );
        }
    }

    ### callbacks?
    if( my $sub = $self->___callback ) {
        $val = eval { $sub->( $self, $method, ($assign ? [$val] : []) ) };

        ### register the error
        $self->___error( $@, 1 ), return if $@;
    }

    ### now we can actually assign it
    if( $assign ) {
        $self->___set( $method, $val ) or return;
    }

    return [$val];
}

=head2 $val = $self->___get( METHOD_NAME );

Method to directly access the value of the given accessor in the
object. It circumvents all calls to allow checks, callbacks, etc.

Use only if you C<Know What You Are Doing>! General usage for
this functionality would be in your own custom callbacks.

=cut

### XXX O::A::lvalue is mirroring this behaviour! if this
### changes, lvalue's autoload must be changed as well
sub ___get {
    my $self    = shift;
    my $method  = shift or return;
    return $self->{$method}->[VALUE];
}

=head2 $bool = $self->___set( METHOD_NAME => VALUE );

Method to directly set the value of the given accessor in the
object. It circumvents all calls to allow checks, callbacks, etc.

Use only if you C<Know What You Are Doing>! General usage for
this functionality would be in your own custom callbacks.

=cut

sub ___set {
    my $self    = shift;
    my $method  = shift or return;

    ### you didn't give us a value to set!
    @_ or return;
    my $val     = shift;

    ### if there's more arguments than $self, then
    ### replace the method called by the accessor.
    ### XXX implement rw vs ro accessors!
    $self->{$method}->[VALUE] = $val;

    return 1;
}

=head2 $bool = $self->___alias( ALIAS => METHOD );

Method to directly alias one accessor to another for
this object. It circumvents all sanity checks, etc.

Use only if you C<Know What You Are Doing>!

=cut

sub ___alias {
    my $self    = shift;
    my $alias   = shift or return;
    my $method  = shift or return;

    $self->{ $alias }->[ALIAS] = $method;

    return 1;
}

sub ___debug {
    return unless $DEBUG;

    my $self = shift;
    my $msg  = shift;

    local $Carp::CarpLevel += 1;

    carp($msg);
}

sub ___error {
    my $self = shift;
    my $msg  = shift;
    my $lvl  = shift || 0;
    local $Carp::CarpLevel += ($lvl + 1);
    $FATAL ? croak($msg) : carp($msg);
}

### objects might be overloaded.. if so, we can't trust what "$self"
### will return, which might get *really* painful.. so check for that
### and get their unoverloaded stringval if needed.