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

Felix Antonius Wilhelm Ostmann Wed, 29 Aug 2007 11:12:26 -0700

OK, first the problem:

we have build some classes with Attribute::Handlers (was inspired fromAttribute::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 oursins

$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 "fromstorage"


               # ist neuer Wert != alter Wert, warnung ausgeben

if( defined($_) ^ defined($value) or defined($_) && $_ne $value ) {carp "Property $property from database areinconsistent";

                   $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;



_______________________________________________
List: [email protected]
Listinfo: http://lists.rawmode.org/mailman/listinfo/catalyst
Searchable archive: http://www.mail-archive.com/[email protected]/
Dev site: http://dev.catalyst.perl.org/

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

Reply via email to