Changeset 4716

Timestamp:

01/16/08 23:28:25 (5 years ago)

Author:

yappo

Message:

lang/perl/Class-Accessor-Lvalue-Trigger: code tidy and add tests

Location:

lang/perl/Class-Accessor-Lvalue-Trigger/trunk

Files:

• Makefile.PL (modified) (1 diff)
• lib/Class/Accessor/Lvalue/Trigger.pm (modified) (5 diffs)
• t/01_simple.t (modified) (2 diffs)
• t/01_trigger_method_overwrite.t (added)
• t/02_simple_ro.t (added)
• t/03_simple_wo.t (added)
• t/04_mix.t (added)

lang/perl/Class-Accessor-Lvalue-Trigger/trunk/Makefile.PL

@@ -4 +4 @@
 
 requires $_ for (qw/
-    Class::Accessor::Fast
+    Class::Accessor
     Want
 /);

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

@@ -3 +3 @@
 use strict;
 use warnings;
+use base 'Class::Accessor';
+
 our $VERSION = '0.01';
-use base 'Class::Accessor::Fast';
 
-our $TRIGGER_METHOD = 'lvalue_accessor_trigger';
+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) = @_;
 
-    my $method = $TRIGGER_METHOD;
     return sub :lvalue {
         my $self = shift;
-        if (ref $method eq 'CODE') {
-            $method->($self, $name, 'rw', @_);
-        } elsif ($self->can($method)) {
-            $self->$method($name, 'rw', @_);
+        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};
@@ -27 +44 @@
     require Want;
 
-    my $method = $TRIGGER_METHOD;
     return sub :lvalue {
         my $self = shift;
@@ -33 +49 @@
             my $caller = caller;
             require Carp;
-            Carp::croak("'$caller' cannot alter the value of '$name' on ".
+            Carp::croak("'$caller' cannot alter the value of '$name' on ".
                           "objects of class '$class'");
         }
-        if (ref $method eq 'CODE') {
-            $method->($self, $name, 'ro', @_);
-        } elsif ($self->can($method)) {
-            $self->$method($name, 'ro', @_);
+        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};
@@ -49 +65 @@
     require Want;
 
-    my $method = $TRIGGER_METHOD;
     return sub :lvalue {
         my $self = shift;
@@ -55 +70 @@
             my $caller = caller;
             require Carp;
-            Carp::croak("'$caller' cannot access the value of '$name' on ".
+            Carp::croak("'$caller' cannot access the value of '$name' on ".
                           "objects of class '$class'");
         }
-        if (ref $method eq 'CODE') {
-            $method->($self, $name, 'wo', @_);
-        } elsif ($self->can($method)) {
-            $self->$method($name, 'ro', @_);
+        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};

lang/perl/Class-Accessor-Lvalue-Trigger/trunk/t/01_simple.t

@@ -2 +2 @@
 use strict;
 use warnings;
-use base 't::MyClassBase';
-__PACKAGE__->mk_accessors(qw/ a /);
+use base 'Class::Accessor::Lvalue::Trigger';
+__PACKAGE__->mk_accessors(qw/ a b c /);
 
 package main;
@@ -14 +14 @@
 isa_ok $obj, 'Class::Accessor::Lvalue::Trigger';
 
+$obj->c = 0;
+
 $obj->a = 'foo';
 is $obj->a, 'foo';
-is $obj->{last}, 'a';
-is $obj->{arg0}, undef;
+is $obj->c, 0;
 
-$obj->a('baz') = 'bar';
-is $obj->{last}, 'a';
-is $obj->{arg0}, 'baz';
-is $obj->a, 'bar';
-is $obj->{arg0}, undef;
+$obj->c++;
+is $obj->a, 'foo';
+is $obj->c, 1;
+
+$obj->b = 'bar';
+is $obj->a, 'foo';
+is $obj->b, 'bar';
+is $obj->c, 1;
+
+$obj->c++;
+is $obj->a, 'foo';
+is $obj->b, 'bar';
+is $obj->c, 2;
+
+$obj->a = 'baz';
+is $obj->a, 'baz';
+is $obj->b, 'bar';
+is $obj->c, 2;
+
+$obj->c++;
+is $obj->a, 'baz';
+is $obj->b, 'bar';
+is $obj->c, 3;