r37687 - in /branches/upstream/libcoat-persistent-perl/current: lib/Coat/Persistent.pm t/007_unique.t t/018_find_with_undef.t t/019_state_object.t
ansgar-guest at users.alioth.debian.org
ansgar-guest at users.alioth.debian.org
Sat Jun 6 16:00:25 UTC 2009
Author: ansgar-guest
Date: Sat Jun 6 16:00:13 2009
New Revision: 37687
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=37687
Log:
[svn-upgrade] Integrating new upstream version, libcoat-persistent-perl (0.104)
Added:
branches/upstream/libcoat-persistent-perl/current/t/018_find_with_undef.t
branches/upstream/libcoat-persistent-perl/current/t/019_state_object.t
Modified:
branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm
branches/upstream/libcoat-persistent-perl/current/t/007_unique.t
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=37687&op=diff
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm (original)
+++ branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm Sat Jun 6 16:00:13 2009
@@ -18,11 +18,15 @@
use DBIx::Sequence;
use SQL::Abstract;
+# Constants
+use constant CP_ENTRY_NEW => 0;
+use constant CP_ENTRY_EXISTS => 1;
+
# Module meta-data
use vars qw($VERSION @EXPORT $AUTHORITY);
use base qw(Exporter);
-$VERSION = '0.102';
+$VERSION = '0.104';
$AUTHORITY = 'cpan:SUKRIA';
@EXPORT = qw(has_p has_one has_many);
@@ -75,6 +79,31 @@
undef $MAPPINGS->{'!cache'}{$class};
}
+# A singleton that stores the driver/module mappings
+# The ones here are default drivers that are known to be compliant
+# with Coat::Persistent.
+# Any DBI driver should work though.
+my $drivers = {
+ csv => 'DBI:CSV',
+ mysql => 'dbi:mysql',
+ sqlite => 'dbi:SQLite',
+};
+sub drivers { $drivers }
+
+# Accessor to a driver
+sub get_driver {
+ my ($class, $driver) = @_;
+ confess "driver needed" unless $driver;
+ return $class->drivers->{$driver};
+}
+
+# This lets you add the DBI driver you want to use
+sub add_driver {
+ my ($class, $driver, $module) = @_;
+ confess "driver and module needed" unless $driver and $module;
+ $class->drivers->{$driver} = $module;
+}
+
# This is the configration stuff, you basically bind a class to
# a DBI driver
sub map_to_dbi {
@@ -84,11 +113,9 @@
# if map_to_dbi is called from Coat::Persistent, this is the default dbh
$class = '!default' if $class eq 'Coat::Persistent';
- my $drivers = {
- mysql => 'dbi:mysql',
- csv => 'DBI:CSV',
- };
- confess "No such driver : $driver"
+ my $drivers = Coat::Persistent->drivers;
+
+ confess "No such driver : $driver, please register the driver first with add_driver()"
unless exists $drivers->{$driver};
# the csv driver needs to load the appropriate DBD module
@@ -444,6 +471,7 @@
$obj->{$field} = $r->{$field};
}
+ $obj->{_db_state} = CP_ENTRY_EXISTS;
push @objects, $obj;
}
}
@@ -465,6 +493,11 @@
sub init_on_find {
+}
+
+sub BUILD {
+ my ($self) = @_;
+ $self->{_db_state} = CP_ENTRY_NEW;
}
sub validate {
@@ -550,7 +583,7 @@
confess "Cannot save without a mapping defined for class " . ref $self
unless defined $dbh;
- # first call validate to check the object is sane
+ # make sure the object is sane
$self->validate();
# all the attributes of the class
@@ -558,8 +591,9 @@
# a hash containing attr/value pairs for the current object.
my %values = map { $_ => $self->$_ } @fields;
- # if we have an id, update
- if ( defined $self->$primary_key ) {
+ # if not a new object, we have to update
+ if ( $self->_db_state == CP_ENTRY_EXISTS ) {
+
# generate the SQL
my ($sql, @values) = $sql_abstract->update(
$table_name, \%values, { $primary_key => $self->$primary_key});
@@ -569,11 +603,17 @@
or confess "Unable to execute query \"$sql\" : $DBI::errstr";
}
- # no id, insert with a valid id
+ # new object, insert
else {
+ # if the id has been touched, trigger an error, that's not possible
+ # with the use of DBIx::Sequence
+ if ($self->{id}) {
+ confess "The id has been set on a newborn object of class ".ref($self).", cannot save, id would change";
+ }
+
# get our ID from the sequence
$self->$primary_key( $self->_next_id );
-
+
# generate the SQL
my ($sql, @values) = $sql_abstract->insert(
$table_name, { %values, $primary_key => $self->$primary_key });
@@ -583,6 +623,8 @@
my $sth = $dbh->prepare($sql);
$sth->execute( @values )
or confess "Unable to execute query \"$sql\" : $DBI::errstr";
+
+ $self->{_db_state} = CP_ENTRY_EXISTS;
}
# if subobjects defined, save them
@@ -654,6 +696,13 @@
my $sequence = new DBIx::Sequence({ dbh => $dbh });
my $id = $sequence->Next($table);
return $id;
+}
+
+# Returns a constant describing if the object exists or not
+# already in the underlying DB
+sub _db_state {
+ my ($self) = @_;
+ return $self->{_db_state} ||= CP_ENTRY_NEW;
}
# DBIx::Sequence needs two tables in the schema,
@@ -768,6 +817,34 @@
either choose to define a default mapper (in most of the cases this is what
you want) or define a mapper for a specific class.
+In order for your mapping to be possible, the driver you use must be known by
+Coat::Persistent, you can modify its driver mapping matrix if needed.
+
+=over 4
+
+=item B<drivers( )>
+
+Return a hashref representing all the drivers mapped.
+
+ MyClass->drivers;
+
+=item B<get_driver( $name )>
+
+Return the Perl module of the driver defined for the given driver name.
+
+ MyClass->get_driver( 'mysql' );
+
+=item B<add_driver( $name, $module )>
+
+Add or replace a driver mapping rule.
+
+ MyClass->add_driver( sqlite => 'dbi:SQLite' );
+
+=back
+
+Then, you can use your driver in mapping rules. Basically, the mapping will
+generate a DBI-E<gt>connect() call.
+
=over 4
=item B<Coat::Persistent-E<gt>map_to_dbi $driver, @options >
@@ -905,12 +982,6 @@
=over 4
-=item B<find( @conditions, \%options )>
-
-Find operates with three different retrieval approaches:
-
-=over 4
-
=item I<Find by id>: This can either be a specific id or a list of ids (1, 5,
6)
Modified: branches/upstream/libcoat-persistent-perl/current/t/007_unique.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/t/007_unique.t?rev=37687&op=diff
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/t/007_unique.t (original)
+++ branches/upstream/libcoat-persistent-perl/current/t/007_unique.t Sat Jun 6 16:00:13 2009
@@ -13,10 +13,11 @@
Person->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)");
-foreach my $name ('Joe', 'John', 'Brenda') {
+foreach my $name ('MisterJoe', 'MisterJohn', 'MissBrenda') {
my $p = new Person name => $name, age => 20;
$p->save;
}
@@ -24,10 +25,10 @@
# tests
my $p;
eval {
- $p = new Person name => 'Joe';
+ $p = Person->new(name => 'MisterJoe');
$p->save;
};
-ok( $@, "Value Joe violates unique constraint for attribute name");
+ok( $@, "Value MisterJoe violates unique constraint for attribute name");
# clean
$dbh->do("DROP TABLE person");
Added: branches/upstream/libcoat-persistent-perl/current/t/018_find_with_undef.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/t/018_find_with_undef.t?rev=37687&op=file
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/t/018_find_with_undef.t (added)
+++ branches/upstream/libcoat-persistent-perl/current/t/018_find_with_undef.t Sat Jun 6 16:00:13 2009
@@ -1,0 +1,43 @@
+use strict;
+use warnings;
+use Test::More 'no_plan';
+
+BEGIN { use_ok 'Coat::Persistent' }
+{
+ package Person;
+ use Coat;
+ use Coat::Persistent;
+ has_p name => (isa => 'Str');
+ has_p age => (isa => 'Int');
+ has_p nickname => (is => 'rw',isa => 'Str');
+}
+
+Person->map_to_dbi('csv', 'f_dir=./t/csv-test-database');
+# Person->map_to_dbi('mysql' => 'coat', 'dbuser' => 'dbpass');
+
+# fixture
+my $dbh = Person->dbh;
+$dbh->do("CREATE TABLE person (id INTEGER, name CHAR(64), age INTEGER, nickname CHAR(64), secondname CHAR(64))");
+Person->create([
+ { name => 'John', age => 20, nickname => 'Johnny' },
+ { name => 'Brenda', age => 20 },
+]);
+$dbh->do("UPDATE person SET secondname='Junior' WHERE name='John'");
+
+# test the find with a list of IDs
+my ($john, $brenda) = Person->find(1, 2);
+
+print $brenda->dump;
+exit;
+
+is($john->nickname, 'Johnny', 'nickname set');
+is($brenda->nickname, undef, 'nickname not set');
+# since secondname is not Coat-declared I have to access the variable directly, not with method
+is($john->{secondname}, 'Junior', 'second name(not Coat-declared) set');
+is($brenda->{secondname}, undef, 'second name(not Coat-declared) not set');
+
+
+# remove the test db
+$dbh->do("DROP TABLE person");
+$dbh->do("DROP TABLE dbix_sequence_state");
+$dbh->do("DROP TABLE dbix_sequence_release");
Added: branches/upstream/libcoat-persistent-perl/current/t/019_state_object.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/t/019_state_object.t?rev=37687&op=file
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/t/019_state_object.t (added)
+++ branches/upstream/libcoat-persistent-perl/current/t/019_state_object.t Sat Jun 6 16:00:13 2009
@@ -1,0 +1,42 @@
+use strict;
+use warnings;
+use Test::More 'no_plan';
+
+BEGIN { use_ok 'Coat::Persistent' }
+{
+ package Person;
+ use Coat;
+ use Coat::Persistent;
+ has_p name => (isa => 'Str');
+ has_p age => (isa => 'Int');
+ has_p nickname => (is => 'rw',isa => 'Str');
+}
+
+Person->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, nickname CHAR(64), secondname CHAR(64))");
+
+# tests
+my $john = Person->create(name => 'John');
+is( Coat::Persistent::CP_ENTRY_EXISTS, $john->_db_state, 'CP_ENTRY_EXISTS on create');
+
+my $john2 = Person->find($john->id);
+ok( defined $john2, 'create worked' );
+is( Coat::Persistent::CP_ENTRY_EXISTS, $john2->_db_state, 'CP_ENTRY_EXISTS on find');
+
+my $brenda = Person->new( name => 'Brenda' );
+is(Coat::Persistent::CP_ENTRY_NEW, $brenda->_db_state, 'CP_ENTRY_NEW on new object' );
+
+$brenda->id(4); # hey we change the primary key here, cannot work !
+eval { $brenda->save; };
+ok($@, 'cannot touch a newborn object id');
+
+my $bob = Person->create(name => 'Bob');
+ok($bob->id != $brenda->id, 'id are not messed');
+
+# 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