root/lang/perl/Class-Accessor-Lvalue-Trigger/trunk/lib/Class/Accessor/Lvalue/Trigger.pm @ 4716

package Class::Accessor::Lvalue::Trigger;

use strict;
use warnings;
use base 'Class::Accessor';

our $VERSION = '0.01';

our $TRIGGER_METHOD = sub {
    my $self = shift;
    my $name = shift;

    my $last_name  = $self->{__class_accessor_lvalue_trigger_lastname};
    my $last_value = $self->{__class_accessor_lvalue_trigger_lastvalue};

    $self->set($last_name, $self->{$last_name}, $last_value, @_) if $last_name;
    $self->{$name} = $self->get($name, @_);

    $self->{__class_accessor_lvalue_trigger_lastname}  = $name;
    $self->{__class_accessor_lvalue_trigger_lastvalue} = $self->{$name};

    $self->{$name};
};

sub set { shift->SUPER::set(@_[1..2]) }
sub get { shift->SUPER::get($_[0]) }

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

    return sub :lvalue {
        my $self = shift;
        if (ref $TRIGGER_METHOD) {
            $TRIGGER_METHOD->($self, $name, 'rw', @_) if  ref $TRIGGER_METHOD eq 'CODE'
        } elsif (defined $TRIGGER_METHOD) {
            $self->$TRIGGER_METHOD($name, 'rw', @_);
        }
        $self->{$name};
    };
}

sub make_ro_accessor {
    my($class, $name) = @_;
    require Want;

    return sub :lvalue {
        my $self = shift;
        if (Want::want('LVALUE')) {
            my $caller = caller;
            require Carp;
            Carp::croak("'$caller' cannot alter the value of '$name' on ".
                          "objects of class '$class'");
        }
        if (ref $TRIGGER_METHOD) {
            $TRIGGER_METHOD->($self, $name, 'ro', @_) if  ref $TRIGGER_METHOD eq 'CODE'
        } elsif (defined $TRIGGER_METHOD) {
            $self->$TRIGGER_METHOD($name, 'ro', @_);
        }
        return $self->{$name};
    };
}

sub make_wo_accessor {
    my($class, $name) = @_;
    require Want;

    return sub :lvalue {
        my $self = shift;
        unless (Want::want('LVALUE')) {
            my $caller = caller;
            require Carp;
            Carp::croak("'$caller' cannot access the value of '$name' on ".
                          "objects of class '$class'");
        }
        if (ref $TRIGGER_METHOD) {
            $TRIGGER_METHOD->($self, $name, 'wo', @_) if  ref $TRIGGER_METHOD eq 'CODE'
        } elsif (defined $TRIGGER_METHOD) {
            $self->$TRIGGER_METHOD($name, 'wo', @_);
        }
        $self->{$name};
    };
}

1;
__END__

=head1 NAME

Class::Accessor::Lvalue::Trigger -

=head1 SYNOPSIS

  use Class::Accessor::Lvalue::Trigger;

=head1 DESCRIPTION

Class::Accessor::Lvalue::Trigger is

=head1 AUTHOR

Kazuhiro Osawa E<lt>ko@yappo.ne.jpE<gt>

=head1 SEE ALSO

L<Class::Accessor>, L<Class::Accessor::Lvalue::Fast>

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut