r26052 - in /branches/upstream/libcoat-persistent-perl/current: lib/Coat/Persistent.pm lib/Coat/Persistent/Meta.pm t/019_mix.t
ansgar-guest at users.alioth.debian.org
ansgar-guest at users.alioth.debian.org
Wed Oct 15 16:26:45 UTC 2008
Author: ansgar-guest
Date: Wed Oct 15 16:26:41 2008
New Revision: 26052
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=26052
Log:
[svn-upgrade] Integrating new upstream version, libcoat-persistent-perl (0.102)
Added:
branches/upstream/libcoat-persistent-perl/current/t/019_mix.t
Modified:
branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm
branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Meta.pm
Modified: branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm?rev=26052&op=diff
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm (original)
+++ branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm Wed Oct 15 16:26:41 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: branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Meta.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Meta.pm?rev=26052&op=diff
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Meta.pm (original)
+++ branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Meta.pm Wed Oct 15 16:26:41 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
Added: branches/upstream/libcoat-persistent-perl/current/t/019_mix.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/t/019_mix.t?rev=26052&op=file
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/t/019_mix.t (added)
+++ branches/upstream/libcoat-persistent-perl/current/t/019_mix.t Wed Oct 15 16:26:41 2008
@@ -1,0 +1,44 @@
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+BEGIN { use_ok 'Coat::Persistent' }
+
+{
+ package Person;
+ use Coat;
+ use Coat::Persistent;
+
+ has_p 'name' => (isa => 'Str');
+ has_p 'age' => (isa => 'Int');
+
+ has abc => (isa => 'Str');
+
+ sub BUILD {
+ $_[0]->abc('123');
+ }
+
+ __PACKAGE__->map_to_dbi('csv', 'f_dir=./t/csv-test-database');
+}
+
+# fixture
+my $dbh = Person->dbh;
+$dbh->do("CREATE TABLE person (id INTEGER, name CHAR(64), age INTEGER)");
+
+# TESTS
+Person->create([
+ { name => 'Brenda', age => 31 },
+]);
+
+# test the find with a list of IDs
+my ($brenda) = Person->find(1);
+
+is( $brenda->abc, '123', 'on a 123');
+
+
+ok( defined $brenda, 'defined $brenda' );
+
+# remove the test db
+$dbh->do("DROP TABLE person");
+$dbh->do("DROP TABLE dbix_sequence_state");
+$dbh->do("DROP TABLE dbix_sequence_release");
More information about the Pkg-perl-cvs-commits
mailing list