[Catalyst] Attribute::Handlers wont work in own classes under catalyst

[Felix Antonius Wilhelm Ostmann]

OK, first the problem:

we have build some classes with Attribute::Handlers (was inspired from 
Attribute::Property)

This works realy fine!

after a few tests we gone use this classes under catalyst ... and ... 
dont work :-/ under catalyst our classes dont use Attribute::Handlers 
:-/ we declare UNIVERSAL::Property and then use "sub nondigit : Property 
{ defined && !m{[0-9]} }" (see the code)

then you can call: $obj->nondigit(4) and it will croak or 
$obj->nondigit("car") and it will set the object-property nondigit to "car".

under catalyst he ignore the redefined sub in UNIVERSAL::Property ... 
no, he dont call UNIVERSAL::Property to redefine sub :-/


MfG
Felix Ostmann



OK, here the code, you can test it with (works):
perl -d -MData::Dumper -MmyExample -e 'my $e = myExample->create(); 
$e->nondigit("car"); print Dumper($e);'
or
perl -d -MData::Dumper -MmyExample -e 'my $e = myExample->create(); 
$e->nondigit(4); print Dumper($e);'


under catalyst (wont work):
sub default : Private {
my ($self, $c) = @_;
use myExample;
use Data::Dumper;
my $e = myExample->create();
$e->nondigit("car");
$c->response->body( Dumper($e) );
}



CODE:

package myExample;

use strict;
use warnings;

use 5.006;
use Attribute::Handlers;
use Carp qw/carp croak/;

$Carp::Internal{q/Attribute::Handlers/}++;  # may we be forgiven for our 
sins
$Carp::Internal{+__PACKAGE__}++;

sub UNIVERSAL::Property : ATTR(CODE) {
    my (undef, $self_glob, $check_code) = @_;

    ref($self_glob)
        or croak "Cannot use property attribute with anonymous sub";

    my $property = *$self_glob{NAME};

    defined(&$self_glob)
        or undef $check_code;

    no warnings 'redefine';

    *$self_glob = sub {
        (my $self, local $_) = @_;

        if( @_ == 1 ) {
            exists($self->{_property}->{_current}->{$property})
                or croak "Property $property not loaded";

            return $self->{_property}->{_current}->{$property};
        }

        if( @_ == 2 ) {
            ref($_)
                and croak "Invalid value for $property property, no refs";

            # Property wurde geladen, sonst Abbruch
            $self->{_in_storage} && 
!exists($self->{_property}->{_storage}->{$property})
                and croak "Property $property not loaded";

            my $value = $_;

            # überprüfe neuen Wert auf Gültigkeit, sonst Abbruch
            defined($check_code) && !$check_code->($self, $_)
                and croak "Invalid value for $property property";

            if( !defined($self->{_in_storage}) ) {
                # status "schammig"es Objekt, dann alles laden als "from 
storage"

                # ist neuer Wert != alter Wert, warnung ausgeben
                if( defined($_) ^ defined($value) or defined($_) && $_ 
ne $value ) {
                    carp "Property $property from database are 
inconsistent";
                    $self->{_property}->{_storage}->{$property} = $value;
                }
                else {
                    $self->{_property}->{_storage}->{$property} = $_;
                }

            }
            # wenn Objekt in der Datenbank
            elsif( $self->{_in_storage} ) {
                # lösche dirty-Status, wird neu berechnet
                delete($self->{_property}->{_dirty}->{$property});

                # ist neuer Wert != alter Wert, dirty-Status neu setzten
                defined($_) ^ 
defined($self->{_property}->{_storage}->{$property})
                    and $self->{_property}->{_dirty}->{$property} = undef;

                # ist neuer Wert != alter Wert, dirty-Status neu setzten
                defined($_) && $_ ne 
$self->{_property}->{_storage}->{$property}
                    and $self->{_property}->{_dirty}->{$property} = undef;
            }
            # wenn nicht in der Datenbank
            else {
                # auf jeden Fall auf dirty setzten
                $self->{_property}->{_dirty}->{$property} = undef
            }

            return $self->{_property}->{_current}->{$property} = $_;
        }

        croak "Too many arguments for $property method";
    };
}

sub new {
    my ($class, @args) = @_;

    @args
        and croak q{Can't call method "new" with arguments};

    my $self = {
        _property   => {
            _current   => {},
            _storage   => {},
            _dirty     => {},
        },
        _in_storage => undef,
    };

    bless($self, $class);

    return $self;
}

sub create {
    my ($class, @args) = @_;

    @args % 2
        and croak "wrong count of arguments";

    my %customer_row = @args;

    # erstelle Objekt und setzte übergebene Parameter
    my $self = $class->new();
    $self->in_storage(0);
    $self->$_($customer_row{$_})  for( keys(%customer_row) );

    return $self;
}

sub in_storage {
    my ($self, $in_storage) = @_;

    if( @_ == 1 ) {
        return $self->{_in_storage};
    }

    if( @_ == 2 ) {
        if( !defined($in_storage) ) {
            $self->{_property}->{_storage}->{$_} = 
$self->{_property}->{_current}->{$_}  for( $self->is_changed );
            $self->{_property}->{_dirty}         = {};
        }
        return $self->{_in_storage} = $in_storage;
    }
}

sub is_changed {
    my ($self, $property) = @_;

    return keys(%{$self->{_property}->{_dirty}})  if( !defined($property) );
    return 1                                      if( 
exists($self->{_property}->{_dirty}->{$property}) );
    return 0;
}


## PROPERTIES
sub undef_or_digit : Property { !defined || m{^\d+$} };
sub nondigit       : Property { defined && !m{\d} };


1;