r26054 - in /trunk/libcoat-persistent-perl: debian/changelog lib/Coat/Persistent.pm lib/Coat/Persistent/Meta.pm t/019_mix.t

[ansgar-guest at users.alioth.debian.org]

Author: ansgar-guest
Date: Wed Oct 15 16:36:16 2008
New Revision: 26054

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=26054
Log:
New upstream release.

Added:
    trunk/libcoat-persistent-perl/t/019_mix.t
      - copied unchanged from r26053, branches/upstream/libcoat-persistent-perl/current/t/019_mix.t
Modified:
    trunk/libcoat-persistent-perl/debian/changelog
    trunk/libcoat-persistent-perl/lib/Coat/Persistent.pm
    trunk/libcoat-persistent-perl/lib/Coat/Persistent/Meta.pm

Modified: trunk/libcoat-persistent-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-persistent-perl/debian/changelog?rev=26054&op=diff
==============================================================================
--- trunk/libcoat-persistent-perl/debian/changelog (original)
+++ trunk/libcoat-persistent-perl/debian/changelog Wed Oct 15 16:36:16 2008
@@ -1,3 +1,9 @@
+libcoat-persistent-perl (0.102-1) unstable; urgency=low
+
+  * New upstream release.
+
+ -- Ansgar Burchardt <ansgar at 43-1.org>  Wed, 15 Oct 2008 18:35:01 +0200
+
 libcoat-persistent-perl (0.101-1) unstable; urgency=low
 
   [ Ansgar Burchardt ]

Modified: trunk/libcoat-persistent-perl/lib/Coat/Persistent.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-persistent-perl/lib/Coat/Persistent.pm?rev=26054&op=diff
==============================================================================
--- trunk/libcoat-persistent-perl/lib/Coat/Persistent.pm (original)
+++ trunk/libcoat-persistent-perl/lib/Coat/Persistent.pm Wed Oct 15 16:36:16 2008
@@ -6,6 +6,8 @@
 use Coat::Persistent::Meta;
 use Carp 'confess';
 
+use Data::Dumper;
+
 # Low-level helpers
 use Digest::MD5 qw(md5_base64);
 use Scalar::Util qw(blessed looks_like_number);
@@ -20,7 +22,7 @@
 use vars qw($VERSION @EXPORT $AUTHORITY);
 use base qw(Exporter);
 
-$VERSION   = '0.101';
+$VERSION   = '0.102';
 $AUTHORITY = 'cpan:SUKRIA';
 @EXPORT    = qw(has_p has_one has_many);
 
@@ -134,6 +136,7 @@
     $CONSTRAINTS->{'!syntax'}{$caller}{$attr} = $options{syntax} || undef;
 
     Coat::has( $attr, ( '!caller' => $caller, %options ) );
+    Coat::Persistent::Meta->attribute($caller, $attr);
 
     # find_by_
     my $sub_find_by = sub {
@@ -427,19 +430,20 @@
         # if any rows, let's process them
         if (@$rows) {
             # we have to find out which fields are real attributes
-            my $class_attr = Coat::Meta->all_attributes( $class );
-            my @attrs = keys %$class_attr;
-            
-            # from the columns selected, where are real attributes and virtual ones?
+            my @attrs = Coat::Persistent::Meta->linearized_attributes( $class );
             my $lc = new List::Compare(\@attrs, [keys %{ $rows->[0] }]);
             my @given_attr   = $lc->get_intersection;
             my @virtual_attr = $lc->get_symdiff;
 
             # create the object with attributes, and set virtual ones
             foreach my $r (@$rows) {
+
                 my $obj = $class->new(map { ($_ => $r->{$_}) } @given_attr);
                 $obj->init_on_find();
-                $obj->{$_} = $r->{$_} for @virtual_attr;
+                foreach my $field (@virtual_attr) {
+                    $obj->{$field} = $r->{$field};
+                }
+
                 push @objects, $obj;
             }
         }
@@ -469,7 +473,7 @@
     my $table_name  = Coat::Persistent::Meta->table_name($class);
     my $primary_key = Coat::Persistent::Meta->primary_key($class);
     
-    foreach my $attr (keys %{ Coat::Meta->all_attributes($class)} ) {
+    foreach my $attr (Coat::Persistent::Meta->linearized_attributes($class) ) {
         # checking for syntax validation
         if (defined $CONSTRAINTS->{'!syntax'}{$class}{$attr}) {
             my $regexp = $CONSTRAINTS->{'!syntax'}{$class}{$attr};
@@ -550,7 +554,7 @@
     $self->validate();
 
     # all the attributes of the class
-    my @fields = keys %{ Coat::Meta->all_attributes( ref $self ) };
+    my @fields = Coat::Persistent::Meta->linearized_attributes( ref $self );
     # a hash containing attr/value pairs for the current object.
     my %values = map { $_ => $self->$_ } @fields;
 

Modified: trunk/libcoat-persistent-perl/lib/Coat/Persistent/Meta.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-persistent-perl/lib/Coat/Persistent/Meta.pm?rev=26054&op=diff
==============================================================================
--- trunk/libcoat-persistent-perl/lib/Coat/Persistent/Meta.pm (original)
+++ trunk/libcoat-persistent-perl/lib/Coat/Persistent/Meta.pm Wed Oct 15 16:36:16 2008
@@ -13,6 +13,35 @@
 # accessor to the meta information of a model
 # ex: Coat::Persistent::Meta->model('User')
 sub registry { $META->{ $_[1] } }
+
+sub attribute {
+    my ($self, $class, $attribute) = @_;
+    $META->{ $class }{attributes} ||= [];
+    push @{ $META->{ $class }{'attributes'} }, $attribute;
+}
+
+sub attribute_exists {
+    my ($self, $class, $attribute) = @_;
+    return grep /^$attribute$/, @{ $META->{ $class }{'attributes'} };
+}
+
+sub attributes {
+    my ($self, $class) = @_;
+    $META->{ $class }{'attributes'} ||= [];
+    return @{ $META->{ $class }{'attributes'} };
+}
+
+sub linearized_attributes {
+    my ($self, $class) = @_;
+    
+    my @all = ();
+    foreach my $c (reverse Coat::Meta->linearized_isa( $class ) ) {
+        foreach my $attr (Coat::Persistent::Meta->attributes( $c )) {
+            push(@all, $attr) unless (grep(/^$attr$/, @all));
+        }
+    }
+    return @all;
+}
 
 # this is to avoid writing several times the same setters and 
 # writers for the class