r20655 - in /branches/upstream/libcoat-persistent-perl/current: lib/Coat/Persistent.pm lib/Coat/Persistent/Meta.pm t/015_meta.t t/017_rename.t t/CoatPersistentA.pm t/CoatPersistentB.pm
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Tue Jun 3 17:41:05 UTC 2008
Author: gregoa
Date: Tue Jun 3 17:41:05 2008
New Revision: 20655
URL: http://svn.debian.org/wsvn/?sc=1&rev=20655
Log:
[svn-upgrade] Integrating new upstream version, libcoat-persistent-perl (0.100)
Added:
branches/upstream/libcoat-persistent-perl/current/t/017_rename.t
branches/upstream/libcoat-persistent-perl/current/t/CoatPersistentA.pm
branches/upstream/libcoat-persistent-perl/current/t/CoatPersistentB.pm
Modified:
branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm
branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Meta.pm
branches/upstream/libcoat-persistent-perl/current/t/015_meta.t
Modified: branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm?rev=20655&op=diff
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm (original)
+++ branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm Tue Jun 3 17:41:05 2008
@@ -20,7 +20,7 @@
use vars qw($VERSION @EXPORT $AUTHORITY);
use base qw(Exporter);
-$VERSION = '0.9_6';
+$VERSION = '0.100';
$AUTHORITY = 'cpan:SUKRIA';
@EXPORT = qw(has_p has_one has_many);
@@ -206,17 +206,20 @@
# TODO : later let the user override the bindings
sub has_one {
- my ($owned_class) = @_;
- my $class = caller;
-
+ my ($name, %options) = @_;
+ my $class = caller;
+
+ my $owned_class = $options{class_name} || $name;
my $owned_table_name = Coat::Persistent::Meta->table_name($owned_class);
my $owned_primary_key = Coat::Persistent::Meta->primary_key($owned_class);
+
+ my $attr_name = (defined $options{class_name}) ? $name : $owned_table_name ;
# record the foreign key
my $foreign_key = $owned_table_name . '_' . $owned_primary_key;
has_p $foreign_key => ( isa => 'Int', '!caller' => $class );
- my $symbol = "${class}::${owned_table_name}";
+ my $symbol = "${class}::${attr_name}";
my $code = sub {
my ( $self, $object ) = @_;
@@ -237,6 +240,9 @@
}
};
_bind_code_to_symbol( $code, $symbol );
+
+ # save the accessor defined for that subobject
+ Coat::Persistent::Meta->accessor( $class => $attr_name );
}
# many relations means an instance of class A owns many instances
@@ -244,14 +250,20 @@
# $a->bs returns B->find_by_a_id($a->id)
# * B must provide a 'has_one A' statement for this to work
sub has_many {
- my ($owned_class) = @_;
- my $class = caller;
-
+ my ($name, %options) = @_;
+ my $class = caller;
+
+ my $owned_class = $options{class_name} || $name;
+
# get the SQL table names and primary keys we need
my $table_name = Coat::Persistent::Meta->table_name($class);
my $primary_key = Coat::Persistent::Meta->primary_key($class);
my $owned_table_name = Coat::Persistent::Meta->table_name($owned_class);
my $owned_primary_key = Coat::Persistent::Meta->primary_key($owned_class);
+
+ my $attr_name = (defined $options{class_name})
+ ? $name
+ : $owned_table_name.'s' ;
# FIXME : have to pluralize properly and let the user
# disable the pluralisation.
@@ -269,18 +281,21 @@
else {
foreach my $obj (@list) {
# is the object made of something appropriate?
- confess "Not an object reference, expected $owned_class"
+ confess "Not an object reference, expected $owned_class, got ($obj)"
unless defined blessed $obj;
confess "Not an object of class $owned_class (got "
. blessed($obj) . ")"
unless blessed $obj eq $owned_class;
+
# then set
- $obj->$table_name($self);
+ my $accessor = Coat::Persistent::Meta->accessor( $owned_class) || $table_name;
+ $obj->$accessor($self);
push @{ $self->{_subobjects} }, $obj;
}
+ return scalar(@list) == scalar(@{$self->{_subobjects}});
}
};
- _bind_code_to_symbol( $code, "${class}::${owned_table_name}s" );
+ _bind_code_to_symbol( $code, "${class}::${attr_name}" );
}
# When Coat::Persistent is imported, a couple of actions have to be
@@ -291,9 +306,11 @@
my %options;
%options = @stuff if @stuff % 2 == 0;
- # Don't do our automagick inheritance if main is calling us
+ # Don't do our automagick inheritance if main is calling us or if the
+ # class has already been registered
my $caller = caller;
return if $caller eq 'main';
+ return if defined Coat::Persistent::Meta->registry( $class );
# now, our caller inherits from Coat::Persistent
eval { Coat::_extends_class( ['Coat::Persistent'], $caller ) };
@@ -421,6 +438,7 @@
# 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;
push @objects, $obj;
}
@@ -441,6 +459,9 @@
: $objects[0];
}
+
+sub init_on_find {
+}
sub validate {
my ($self, @args) = @_;
@@ -520,7 +541,7 @@
my $dbh = $class->dbh;
my $table_name = Coat::Persistent::Meta->table_name($class);
my $primary_key = Coat::Persistent::Meta->primary_key($class);
-# warn "save\n\ttable_name: $table_name\n\tprimary_key: $primary_key\n";
+ #warn "save\n\ttable_name: $table_name\n\tprimary_key: $primary_key\n";
confess "Cannot save without a mapping defined for class " . ref $self
unless defined $dbh;
@@ -554,6 +575,7 @@
$table_name, { %values, $primary_key => $self->$primary_key });
# execute the query
+ #warn "sql: $sql ".join(', ', @values);
my $sth = $dbh->prepare($sql);
$sth->execute( @values )
or confess "Unable to execute query \"$sql\" : $DBI::errstr";
@@ -577,6 +599,7 @@
# instance method & stuff
sub _bind_code_to_symbol {
my ( $code, $symbol ) = @_;
+
{
no strict 'refs';
no warnings 'redefine', 'prototype';
Modified: branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Meta.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Meta.pm?rev=20655&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 Tue Jun 3 17:41:05 2008
@@ -8,11 +8,11 @@
my $META = {};
# supported meta attributes for models
-my @attributes = qw(table_name primary_key);
+my @attributes = qw(table_name primary_key accessor);
# accessor to the meta information of a model
# ex: Coat::Persistent::Meta->model('User')
-sub model { $META->{ $_[1] } }
+sub registry { $META->{ $_[1] } }
# this is to avoid writing several times the same setters and
# writers for the class
Modified: branches/upstream/libcoat-persistent-perl/current/t/015_meta.t
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-persistent-perl/current/t/015_meta.t?rev=20655&op=diff
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/t/015_meta.t (original)
+++ branches/upstream/libcoat-persistent-perl/current/t/015_meta.t Tue Jun 3 17:41:05 2008
@@ -1,10 +1,22 @@
use strict;
use warnings;
-use Test::More tests => 7;
+use Test::More tests => 9;
BEGIN { use_ok 'Coat::Persistent::Meta' }
-ok( ! defined(Coat::Persistent::Meta->model('User')),
+use lib './t';
+use CoatPersistentA;
+use CoatPersistentB;
+
+is( Coat::Persistent::Meta->table_name('CoatPersistentA'),
+ 'table_a',
+ 'A is table_a' );
+
+is( Coat::Persistent::Meta->table_name('CoatPersistentB'),
+ 'table_b',
+ 'B is table_b' );
+
+ok( ! defined(Coat::Persistent::Meta->registry('User')),
'model User not defined' );
ok( Coat::Persistent::Meta->table_name(User => 'users' ),
@@ -12,7 +24,7 @@
is( 'users', Coat::Persistent::Meta->table_name('User'),
'table_name == users');
-ok( defined(Coat::Persistent::Meta->model('User')),
+ok( defined(Coat::Persistent::Meta->registry('User')),
'model User defined' );
ok( Coat::Persistent::Meta->primary_key(User => 'id'),
Added: branches/upstream/libcoat-persistent-perl/current/t/017_rename.t
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-persistent-perl/current/t/017_rename.t?rev=20655&op=file
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/t/017_rename.t (added)
+++ branches/upstream/libcoat-persistent-perl/current/t/017_rename.t Tue Jun 3 17:41:05 2008
@@ -1,0 +1,74 @@
+use strict;
+use warnings;
+use Test::More 'no_plan';
+
+BEGIN { use_ok 'Coat::Persistent' }
+
+use Coat::Types;
+
+enum 'Sex' => 'Male', 'Female', '';
+
+{
+ package Person;
+ use Coat;
+ use Coat::Persistent table_name => 'people';
+
+ has_p 'name' => (isa => 'Str');
+ has_p 'age' => (isa => 'Int');
+ has_p sex => (isa => 'Sex');
+
+ has_many 'dogs',
+ class_name => 'Dog';
+
+ package Dog;
+ use Coat;
+ use Coat::Persistent
+ table_name => 'dogs';
+
+
+ has_p name => (isa => 'Str');
+ has_p colour => (isa => 'Str');
+ has_p sex => (isa => 'Sex');
+
+ has_one 'master',
+ class_name => 'Person';
+}
+
+
+# fixture
+Coat::Persistent->map_to_dbi('csv', 'f_dir=./t/csv-test-database');
+
+my $dbh = Person->dbh;
+$dbh->do("CREATE TABLE people (id INTEGER, sex CHAR(64), name CHAR(64), age INTEGER)");
+$dbh->do("CREATE TABLE dogs (id INTEGER, sex CHAR(64), name CHAR(64), colour CHAR(64), people_id INTEGER)");
+
+# TESTS
+
+my $joe = Person->new( name => 'Joe', age => 21 );
+ok( $joe->save, '$p->save' );
+
+my @dogs;
+foreach my $dog_name (qw(medor rintintin pif)) {
+ my $d = Dog->new( name => 'medor', colour => 'white', sex => 'Male', master => $joe);
+ ok( $d->save, "\$$dog_name->save" );
+ push @dogs, $d;
+}
+
+ok( $joe->dogs( @dogs ), '$joe->dogs( @dogs )' );
+ok( $joe->save, '$joe->save' );
+
+ at dogs = Dog->find();
+is( $joe->id, $dogs[0]->people_id, '$dog->people_id is set' );
+
+ at dogs = $joe->dogs;
+ok( @dogs == 3, '$joe->dogs' );
+
+is( $dogs[0]->name, 'medor', 'medor is the first dog of joe' );
+is( $joe->id, $dogs[2]->master->id, 'joe is the master of third dog' );
+
+# remove the test db
+$dbh->do("DROP TABLE people");
+$dbh->do("DROP TABLE dogs");
+$dbh->do("DROP TABLE dbix_sequence_state");
+$dbh->do("DROP TABLE dbix_sequence_release");
+
Added: branches/upstream/libcoat-persistent-perl/current/t/CoatPersistentA.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-persistent-perl/current/t/CoatPersistentA.pm?rev=20655&op=file
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/t/CoatPersistentA.pm (added)
+++ branches/upstream/libcoat-persistent-perl/current/t/CoatPersistentA.pm Tue Jun 3 17:41:05 2008
@@ -1,0 +1,10 @@
+package CoatPersistentA;
+use Coat;
+use Coat::Persistent table_name => 'table_a';
+use Coat::Persistent::Meta;
+
+has_p x => (isa => 'Num');
+
+sub model_meta { Coat::Persistent::Meta->model($_[0]) }
+
+1;
Added: branches/upstream/libcoat-persistent-perl/current/t/CoatPersistentB.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-persistent-perl/current/t/CoatPersistentB.pm?rev=20655&op=file
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/t/CoatPersistentB.pm (added)
+++ branches/upstream/libcoat-persistent-perl/current/t/CoatPersistentB.pm Tue Jun 3 17:41:05 2008
@@ -1,0 +1,12 @@
+package CoatPersistentB;
+use Coat;
+use Coat::Persistent table_name => 'table_b';
+
+use Coat::Persistent::Meta;
+use CoatPersistentA;
+
+has_p x => (isa => 'Num');
+
+sub model_meta { Coat::Persistent::Meta->model($_[0]) }
+
+1;
More information about the Pkg-perl-cvs-commits
mailing list