r20657 - in /trunk/libcoat-persistent-perl: debian/changelog 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:42:52 UTC 2008
Author: gregoa
Date: Tue Jun 3 17:42:51 2008
New Revision: 20657
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=20657
Log:
New upstream release.
Added:
trunk/libcoat-persistent-perl/t/017_rename.t
- copied unchanged from r20656, branches/upstream/libcoat-persistent-perl/current/t/017_rename.t
trunk/libcoat-persistent-perl/t/CoatPersistentA.pm
- copied unchanged from r20656, branches/upstream/libcoat-persistent-perl/current/t/CoatPersistentA.pm
trunk/libcoat-persistent-perl/t/CoatPersistentB.pm
- copied unchanged from r20656, branches/upstream/libcoat-persistent-perl/current/t/CoatPersistentB.pm
Modified:
trunk/libcoat-persistent-perl/debian/changelog
trunk/libcoat-persistent-perl/lib/Coat/Persistent.pm
trunk/libcoat-persistent-perl/lib/Coat/Persistent/Meta.pm
trunk/libcoat-persistent-perl/t/015_meta.t
Modified: trunk/libcoat-persistent-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-persistent-perl/debian/changelog?rev=20657&op=diff
==============================================================================
--- trunk/libcoat-persistent-perl/debian/changelog (original)
+++ trunk/libcoat-persistent-perl/debian/changelog Tue Jun 3 17:42:51 2008
@@ -1,3 +1,9 @@
+libcoat-persistent-perl (0.100-1) UNRELEASED; urgency=low
+
+ * New upstream release.
+
+ -- gregor herrmann <gregoa at debian.org> Tue, 03 Jun 2008 19:41:58 +0200
+
libcoat-persistent-perl (0.9-6-2) unstable; urgency=low
* debian/control:
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=20657&op=diff
==============================================================================
--- trunk/libcoat-persistent-perl/lib/Coat/Persistent.pm (original)
+++ trunk/libcoat-persistent-perl/lib/Coat/Persistent.pm Tue Jun 3 17:42:51 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: 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=20657&op=diff
==============================================================================
--- trunk/libcoat-persistent-perl/lib/Coat/Persistent/Meta.pm (original)
+++ trunk/libcoat-persistent-perl/lib/Coat/Persistent/Meta.pm Tue Jun 3 17:42:51 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: trunk/libcoat-persistent-perl/t/015_meta.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-persistent-perl/t/015_meta.t?rev=20657&op=diff
==============================================================================
--- trunk/libcoat-persistent-perl/t/015_meta.t (original)
+++ trunk/libcoat-persistent-perl/t/015_meta.t Tue Jun 3 17:42:51 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'),
More information about the Pkg-perl-cvs-commits
mailing list