view release on metacpan or  search on metacpan

lib/Class/Accessor/Lvalue.pm  view on Meta::CPAN

use strict;
package Class::Accessor::Lvalue;
use base qw( Class::Accessor );
use Scalar::Util qw(weaken);
use Want qw( want );
our $VERSION = '0.11';

sub make_accessor {
    my ($class, $field) = @_;

    return sub :lvalue {
        tie my $tie, "Class::Accessor::Lvalue::Tied" => $field, @_;
        $tie;
    };
}

sub make_ro_accessor {
    my ($class, $field) = @_;

    return sub :lvalue {
        if (want 'LVALUE') {
            my $caller = caller;
            require Carp;
            Carp::croak("'$caller' cannot alter the value of '$field' on ".
                          "objects of class '$class'");
        }
        tie my $tie, "Class::Accessor::Lvalue::Tied" => $field, @_;
        $tie;
    };
}

sub make_wo_accessor {
    my($class, $field) = @_;

    return sub :lvalue {
        unless (want 'LVALUE') {
            my $caller = caller;
            require Carp;
            Carp::croak("'$caller' cannot access the value of '$field' on ".
                          "objects of class '$class'");
        }
        tie my $tie, "Class::Accessor::Lvalue::Tied" => $field, @_;
        $tie;
    };
}


package Class::Accessor::Lvalue::Tied;
sub TIESCALAR { shift; bless [@_] }

sub STORE {
    my ($field, $self) = @{ shift() };
    $self->set( $field, @_ );
}

sub FETCH {
    my ($field, $self) = @{ shift() };
    $self->get( $field );
}

1;
__END__

=head1 NAME