r38318 - in /branches/upstream/libcoat-persistent-perl/current: ./ lib/Coat/ lib/Coat/Persistent/ lib/Coat/Persistent/Types/ t/
ansgar-guest at users.alioth.debian.org
ansgar-guest at users.alioth.debian.org
Sat Jun 20 08:35:28 UTC 2009
Author: ansgar-guest
Date: Sat Jun 20 08:35:23 2009
New Revision: 38318
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=38318
Log:
[svn-upgrade] Integrating new upstream version, libcoat-persistent-perl (0.210)
Added:
branches/upstream/libcoat-persistent-perl/current/CHANGES
branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Constraint.pm
branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Types/
branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Types.pm
branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Types/MySQL.pm
branches/upstream/libcoat-persistent-perl/current/t/022_storage_value.t
branches/upstream/libcoat-persistent-perl/current/t/023_types_and_coercions.t
Modified:
branches/upstream/libcoat-persistent-perl/current/Makefile.PL
branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent.pm
branches/upstream/libcoat-persistent-perl/current/t/008_syntax.t
Added: branches/upstream/libcoat-persistent-perl/current/CHANGES
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/CHANGES?rev=38318&op=file
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/CHANGES (added)
+++ branches/upstream/libcoat-persistent-perl/current/CHANGES Sat Jun 20 08:35:23 2009
@@ -1,0 +1,11 @@
+2009-06-19 - 0.210 - Alexis Sukrieh
+ * New module Coat::Persistent::Types for providing default types and coercions
+ * Class::Date support for default types
+ * Uses now Class::Date instead of handling time dans dates by hand.
+
+2009-06-19 - 0.200 - Alexis Sukrieh
+
+ * Support for the `store_as' option for attribute declaration.
+ * Added Coat::Persistent::Types::MySQL for providing default data types for
+ MySQL date fields.
+
Modified: branches/upstream/libcoat-persistent-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/Makefile.PL?rev=38318&op=diff
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/Makefile.PL (original)
+++ branches/upstream/libcoat-persistent-perl/current/Makefile.PL Sat Jun 20 08:35:23 2009
@@ -1,16 +1,23 @@
+use strict;
+use warnings;
use ExtUtils::MakeMaker;
WriteMakefile(
- NAME => 'Coat::Persistent',
+ NAME => 'Coat::Persistent',
+ AUTHOR => 'Alexis Sukrieh (sukria) <sukria at cpan.org>',
+ LICENSE => 'perl',
VERSION_FROM => 'lib/Coat/Persistent.pm',
- PREREQ_PM => {
- 'Coat' => '0.1_0.6',
- 'DBI' => '0',
- 'DBIx::Sequence' => 0,
- 'DBD::CSV' => 0, # needed for the test suite
- 'SQL::Abstract' => 0,
- 'List::Compare' => 0,
+ ABSTRACT => "ORM based on the Moose-like engine `Coat'",
+ PREREQ_PM => {
+ 'Coat' => '0.334',
+ 'DBI' => '0',
+ 'DBIx::Sequence' => '0',
+ 'Class::Date' => '0', # For the types defined
+ 'DBD::CSV' => '0', # needed for the test suite
+ 'SQL::Abstract' => '0',
+ 'List::Compare' => '0',
},
- ABSTRACT => "Ruby's ActiveRecord::Base port for Perl (ORM)",
- test => {TESTS => join( ' ', glob( 't/*.t' ))},
+ test => {TESTS => join( ' ', glob( 't/*.t' ))},
+ dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+ clean => { FILES => 't/csv-test-database'},
);
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=38318&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 20 08:35:23 2009
@@ -4,6 +4,7 @@
use Coat;
use Coat::Meta;
use Coat::Persistent::Meta;
+use Coat::Persistent::Constraint;
use Carp 'confess';
use Data::Dumper;
@@ -26,7 +27,7 @@
use vars qw($VERSION @EXPORT $AUTHORITY);
use base qw(Exporter);
-$VERSION = '0.104';
+$VERSION = '0.210';
$AUTHORITY = 'cpan:SUKRIA';
@EXPORT = qw(has_p has_one has_many);
@@ -35,7 +36,6 @@
# configuration place-holders
my $MAPPINGS = {};
-my $CONSTRAINTS = {};
# static accessors
sub mappings { $MAPPINGS }
@@ -53,6 +53,17 @@
$MAPPINGS->{'!cache'}{ $_[0] } ||
$MAPPINGS->{'!cache'}{'!default'} ||
undef;
+}
+
+# Access to the constraint meta data for the current class
+sub has_unique_constraint {
+ my ($class, $attr) = @_;
+ $class->has_constraint($attr, 'unique');
+}
+
+sub has_constraint {
+ my ($class, $attr, $constraint) = @_;
+ Coat::Persistent::Constraint->get_constraint($constraint, $class, $attr) || 0;
}
sub enable_cache {
@@ -139,6 +150,16 @@
_create_dbix_sequence_tables($MAPPINGS->{'!dbh'}{$class});
}
+# This is used if you already have a dbh instead of creating one with
+# map_to_dbi
+sub set_dbh {
+ my ($class, $dbh) = @_;
+ confess "Cannot set an undefined dbh" unless defined $dbh;
+
+ $class = '!default' if $class eq 'Coat::Persistent';
+ $MAPPINGS->{'!dbh'}{$class} = $dbh;
+ _create_dbix_sequence_tables($MAPPINGS->{'!dbh'}{$class});
+}
# This is done to wrap the original Coat::has method so we can
# generate finders for each attribute declared
@@ -158,9 +179,26 @@
confess "package main called has_p" if $caller eq 'main';
# unique field ?
- $CONSTRAINTS->{'!unique'}{$caller}{$attr} = $options{unique} || 0;
- # syntax check ?
- $CONSTRAINTS->{'!syntax'}{$caller}{$attr} = $options{syntax} || undef;
+ if ($options{'unique'}) {
+ Coat::Persistent::Constraint->add_constraint('unique', $caller, $attr, 1);
+ }
+
+ # specific storage type ?
+ if ($options{'store_as'}) {
+ # We need bi-directional coercion for this "store_as" feature ...
+ my $storage_type = Coat::Types::find_type_constraint($options{'store_as'});
+ confess "Unknown type \"".$options{'store_as'}."\" for storage"
+ unless defined $storage_type;
+ confess "No coercion defined for storage type \"".$options{'store_as'}."\""
+ unless $storage_type->has_coercion;
+
+ my $type = Coat::Types::find_type_constraint($options{isa});
+ confess "No cercion for attribute type : \"".$options{isa}."\""
+ unless $type->has_coercion;
+
+ Coat::Persistent::Constraint->add_constraint('store_as', $caller, $attr, $options{'store_as'});
+ $options{coerce} = 1;
+ }
Coat::has( $attr, ( '!caller' => $caller, %options ) );
Coat::Persistent::Meta->attribute($caller, $attr);
@@ -507,16 +545,9 @@
my $primary_key = Coat::Persistent::Meta->primary_key($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};
- confess "Value \"".$self->$attr."\" for attribute \"$attr\" is not valid"
- unless $self->$attr =~ /$regexp/;
- }
# checking for unique attributes on inserting (new objects)
- if ((! defined $self->$primary_key) &&
- $CONSTRAINTS->{'!unique'}{$class}{$attr}) {
+ if ($class->has_unique_constraint($attr)) {
# look for other instances that already have that attribute
my @items = $class->find(["$attr = ?", $self->$attr]);
confess "Value ".$self->$attr." violates unique constraint "
@@ -524,7 +555,6 @@
if @items;
}
}
-
}
sub delete {
@@ -571,6 +601,39 @@
}
}
+# This will return the value as to be stored in the underlying database
+# Most of the time it's just the value of the atrtribute, but it can
+# be different if a 'store_as' type is defined.
+sub get_storage_value_for {
+ my ($self, $attr_name) = @_;
+ my $class = ref $self;
+
+ my $attr = Coat::Meta->attribute($class, $attr_name);
+
+ if ($attr->{store_as}) {
+ my $storing_type = Coat::Types::find_type_constraint($attr->{store_as});
+ return $storing_type->coerce($self->$attr_name);
+ }
+ else {
+ return $self->$attr_name;
+ }
+}
+
+# Takes a value (taken from the DB) and convert it to the real value for the attribute
+sub get_real_value_for {
+ my ($self, $attr_name, $value) = @_;
+ my $class = ref $self;
+
+ my $attr = Coat::Meta->attribute($class, $attr_name);
+ if ($attr->{store_as}) {
+ my $type = Coat::Types::find_type_constraint($attr->{isa});
+ return $type->coerce($value);
+ }
+ else {
+ return $value;
+ }
+}
+
# serialize the instance and save it with the mapper defined
sub save {
my ($self) = @_;
@@ -588,8 +651,9 @@
# all the attributes of the class
my @fields = Coat::Persistent::Meta->linearized_attributes( ref $self );
- # a hash containing attr/value pairs for the current object.
- my %values = map { $_ => $self->$_ } @fields;
+
+ # a hash containing attr/value pairs for the current object
+ my %values = map { $_ => $self->get_storage_value_for($_) } @fields;
# if not a new object, we have to update
if ( $self->_db_state == CP_ENTRY_EXISTS ) {
@@ -811,6 +875,24 @@
=head1 CONFIGURATION
+You have two options for setting a database handle to your class. Either you
+already have a dbh an you set it to your class, or you don't and you let
+Coat::Persistent initialize it.
+
+If you already have a database handle, use Coat::Persistent->set_dbh($dbh),
+otherwise, use the DBI mapping explained below.
+
+=head2 Setting an existing database handle
+
+=over 4
+
+=item B<set_dbh($dbh)>
+
+Set the given database handle for the calling class (set it by default if class
+is Coat::Persistent).
+
+=back
+
=head2 DBI MAPPING
You have to tell Coat::Persistent how to map a class to a DBI driver. You can
Added: branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Constraint.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Constraint.pm?rev=38318&op=file
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Constraint.pm (added)
+++ branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Constraint.pm Sat Jun 20 08:35:23 2009
@@ -1,0 +1,29 @@
+package Coat::Persistent::Constraint;
+
+use strict;
+use warnings;
+
+# Singleton for storing constraints
+my $REGISTRY = {};
+
+sub add_constraint {
+ my ($class, $constraint, $caller, $attribute, $value) = @_;
+ $REGISTRY->{$constraint}{$caller}{$attribute} = $value;
+}
+
+sub get_constraint {
+ my ($class, $constraint, $caller, $attribute) = @_;
+ $REGISTRY->{$constraint}{$caller}{$attribute} || 0;
+}
+
+sub remove_constraint {
+ my ($class, $constraint, $caller, $attribute) = @_;
+ delete $REGISTRY->{$constraint}{$caller}{$attribute};
+}
+
+sub list_constraints {
+ my ($class, $constraint, $caller) = @_;
+ keys %{ $REGISTRY->{$constraint}{$caller} };
+}
+
+1;
Added: branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Types.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Types.pm?rev=38318&op=file
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Types.pm (added)
+++ branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Types.pm Sat Jun 20 08:35:23 2009
@@ -1,0 +1,132 @@
+package Coat::Persistent::Types;
+
+use strict;
+use warnings;
+
+use Coat::Types;
+
+subtype 'UnixTimestamp'
+ => as 'Int'
+ => where { /^\d+$/ && $_ > 0 };
+
+coerce 'UnixTimestamp'
+ => from 'Class::Date'
+ => via { $_->epoch };
+
+coerce 'Class::Date'
+ => from 'UnixTimestamp'
+ => via { Class::Date->new($_) };
+
+subtype 'DateTime'
+ => as 'Str'
+ => where { /^\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d$/ };
+
+coerce 'DateTime'
+ => from 'UnixTimestamp'
+ => via { Class::Date->new($_)->string };
+
+coerce 'UnixTimestamp'
+ => from 'DateTime'
+ => via { Class::Date->new($_)->epoch };
+
+# date
+
+subtype 'Date'
+ => as 'Str'
+ => where { /^\d{4}-\d\d-\d\d$/ };
+
+coerce 'Date'
+ => from 'UnixTimestamp'
+ => via {
+ my $date = Class::Date->new($_);
+ my $str = $date->ymd;
+ $str =~ s/\//-/g;
+ return $str;
+ };
+
+coerce 'UnixTimestamp'
+ => from 'Date'
+ => via { Class::Date->new($_)->epoch };
+
+'Coat::Persistent::Types';
+__END__
+=pod
+
+=head1 NAME
+
+Coat::Persistent::Types
+
+=head1 DESCRIPTION
+
+This module provides a set of types and coercions that are of common use when
+dealing with an database.
+
+By loading this module you are able to use all the types defined here for your
+attribute definitions (either for the 'isa' option or fore the 'store_as' one).
+
+=head1 TYPES
+
+=over 4
+
+=item C<UnixTimestamp>
+
+An Int that is strictly greater than 0 and that represent the time since
+1970-01-01 00:00:01
+
+=item C<Date>
+
+A string representing the date with the following format: YYYY-MM-DD
+
+=item C<DateTime>
+
+=back
+
+=head1 COERCIONS
+
+All the types defined are coerceable from the type UnixTimestamp and the type
+UnixTimestamp can be coerced to all the types defined.
+
+=head1 EXAMPLE
+
+ package Stuff;
+
+ use Coat::Persistent::Types;
+
+ # we have a date field, we want to store it and to handle it as string
+ # formated like YYYY-MM-DD
+ has_p birth_date => (
+ is => 'ro',
+ isa => 'Date',
+ );
+
+ # we have a datetime that's changed whenever the object si touched.
+ # we want to handle the data as a timestamp, and to store it as DateTime string.
+ has_p last_update => (
+ is => 'rw',
+ isa => 'UnixTimestamp',
+ store_as => 'DateTime',
+ );
+
+ # or if you'd rather have a Class::Date object than a UnixTimestamp :
+ has_p last_update => (
+ is => 'rw',
+ isa => 'Class::Date',
+ store_as => 'DateTime',
+ );
+
+=item C<Class::Date>
+
+All the types defined in this module are coerceable from or to the type UnixTimestamp.
+
+=back
+
+=head1 SEE ALSO
+
+L<Coat::Types> L<Coat::Persistent::Types::>
+
+=head1 AUTHOR
+
+Alexis Sukrieh <sukria at cpan.org>
+http://www.sukria.net
+
+=cut
Added: branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Types/MySQL.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Types/MySQL.pm?rev=38318&op=file
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Types/MySQL.pm (added)
+++ branches/upstream/libcoat-persistent-perl/current/lib/Coat/Persistent/Types/MySQL.pm Sat Jun 20 08:35:23 2009
@@ -1,0 +1,105 @@
+package Coat::Persistent::Types::MySQL;
+
+# MySQL types usable in has_p definitions
+# (either for isa or for store_as)
+
+use strict;
+use warnings;
+
+use Coat::Types;
+use Coat::Persistent::Types;
+use Class::Date;
+
+# datetime'
+
+subtype 'MySQL:DateTime'
+ => as 'Str'
+ => where { /^\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d$/ };
+
+coerce 'MySQL:DateTime'
+ => from 'UnixTimestamp'
+ => via { Class::Date->new($_)->string };
+
+coerce 'UnixTimestamp'
+ => from 'MySQL:DateTime'
+ => via { $_->epoch };
+
+# date
+
+subtype 'MySQL:Date'
+ => as 'Str'
+ => where { /^\d{4}-\d\d-\d\d$/ };
+
+coerce 'MySQL:Date'
+ => from 'UnixTimestamp'
+ => via {
+ my $date = Class::Date->new($_);
+ my $str = $date->ymd;
+ $str =~ s/\//-/g;
+ return $str;
+ };
+
+coerce 'UnixTimestamp'
+ => from 'MySQL:Date'
+ => via { Class::Date->new($_)->epoch };
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+Coat::Persistent::Types::MySQL -- Attribute types and coercions for MySQL data types
+
+=head1 DESCRIPTION
+
+The types defined in this module are here to provide simple and transparent
+storage of MySQL data types. This is done for atttributes you want to store
+with a different value than the one the object has.
+
+For instance, if you have a datetime field, you may want to store it as a MySQL
+"datetime" format (YYYY-MM-DD HH:MM:SS) and handle it in your code as a
+timestamp, which is much more convinient for updates.
+
+This is possible by using the types defined in this module.
+
+=head1 EXAMPLE
+
+We have a 'created_at' attribute, we want to handle it as a timestamp and store
+it as a MySQL datetime field.
+
+ use Coat::Persistent::Types::MySQL;
+
+ has_p 'created_at' => (
+ is => 'rw',
+ isa => 'Int',
+ store_as => 'MySQL:DateTime,
+ );
+
+Then, whenever a value that validates the MySQL:DateTime format is assigned to
+that field, it will be coerced to an Int. On the other hand, whenever an entry
+has to be saved, the value used for storage will be the result of a coercion
+from Int to MySQL:DateTime.
+
+=head1 TYPES
+
+The following types are provided by this module
+
+=over 4
+
+=item MySQL:DateTime : YYYY-MM-DD HH:MM:SS
+
+=item MySQL:Date : YYYY-MM-DD
+
+=back
+
+=head1 SEE ALSO
+
+L<Coat::Types>, L<Coat::Persistent>
+
+=head1 AUTHOR
+
+Alexis Sukrieh <sukria at cpan.org>
+
+=cut
Modified: branches/upstream/libcoat-persistent-perl/current/t/008_syntax.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/t/008_syntax.t?rev=38318&op=diff
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/t/008_syntax.t (original)
+++ branches/upstream/libcoat-persistent-perl/current/t/008_syntax.t Sat Jun 20 08:35:23 2009
@@ -6,8 +6,13 @@
{
package Person;
use Coat;
+ use Coat::Types;
use Coat::Persistent;
- has_p name => (isa => 'Str', unique => 1, syntax => '[a-zA-Z]{2}');
+
+ subtype 'Person:Name' => as 'Str' => where { /[a-zA-Z]{2}/ };
+ has_p name => (isa => 'Person:Name', unique => 1);
+ #has_p name => (isa => 'Str', unique => 1, syntax => '[a-zA-Z]{2}'); # DEPRECATED now
+
has_p age => (isa => 'Int');
}
Added: branches/upstream/libcoat-persistent-perl/current/t/022_storage_value.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/t/022_storage_value.t?rev=38318&op=file
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/t/022_storage_value.t (added)
+++ branches/upstream/libcoat-persistent-perl/current/t/022_storage_value.t Sat Jun 20 08:35:23 2009
@@ -1,0 +1,62 @@
+use strict;
+use warnings;
+use Test::More 'no_plan';
+
+BEGIN { use_ok 'Coat::Persistent' }
+
+
+{
+ package Person;
+ use Coat;
+ use Coat::Persistent table_name => 'people', primary_key => 'pid';
+ use Coat::Persistent::Types::MySQL;
+
+ has_p 'name' => (isa => 'Str');
+ has_p 'age' => (isa => 'Int');
+
+ has_p 'created_at' => (
+ is => 'rw',
+ isa => 'UnixTimestamp',
+ store_as => 'MySQL:DateTime',
+ );
+
+ has_p 'birth_date' => (
+ is => 'rw',
+ isa => 'UnixTimestamp',
+ store_as => 'MySQL:Date',
+ );
+}
+
+
+# fixture
+Coat::Persistent->map_to_dbi('csv', 'f_dir=./t/csv-test-database');
+
+my $dbh = Person->dbh;
+$dbh->do("CREATE TABLE people (pid INTEGER, birth_date CHAR(4), name CHAR(64), age INTEGER, created_at CHAR(30))");
+
+# TESTS
+
+my $t = time;
+my $joe = Person->new(
+ name => 'Joe',
+ age => 21,
+ created_at => $t,
+ birth_date => '1983-02-06');
+
+my $t_str = $joe->get_storage_value_for('created_at');
+
+is($t, $joe->created_at, "created_at is an int : $t ");
+ok($t ne $t_str, "created_at storage value is : $t_str");
+is($t, $joe->get_real_value_for('created_at', $joe->get_storage_value_for('created_at')), 'real_value is correctly converted');
+ok($joe->save, '$joe->save');
+
+my $joe2 = Person->find($joe->pid);
+is($joe2->created_at, $t, 'created_at is still an Int when fetched');
+ok($joe2->created_at(time() + 3600), 'we can play with numbers in created_at');
+ok($joe2->save, '$joe->save');
+
+ok($joe2->birth_date('1979-11-20'), 'birth_date set with a Date');
+ok($joe2->save, '$joe2->save');
+ok($joe2->birth_date ne '1979-11-20', 'birth_date was coerced: '.$joe2->birth_date);
+
+$dbh->do("DROP TABLE people");
Added: branches/upstream/libcoat-persistent-perl/current/t/023_types_and_coercions.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-persistent-perl/current/t/023_types_and_coercions.t?rev=38318&op=file
==============================================================================
--- branches/upstream/libcoat-persistent-perl/current/t/023_types_and_coercions.t (added)
+++ branches/upstream/libcoat-persistent-perl/current/t/023_types_and_coercions.t Sat Jun 20 08:35:23 2009
@@ -1,0 +1,63 @@
+use strict;
+use warnings;
+use Test::More 'no_plan';
+
+BEGIN { use_ok 'Coat::Persistent' }
+
+
+{
+ package Person;
+ use Coat;
+ use Coat::Persistent table_name => 'people', primary_key => 'pid';
+ use Coat::Persistent::Types::MySQL;
+
+ has_p 'created_at' => (
+ isa => 'UnixTimestamp',
+ store_as => 'DateTime',
+ );
+
+ has_p updated_at => (
+ isa => 'Class::Date',
+ store_as => 'UnixTimestamp',
+ );
+
+ has_p 'birth_date' => (
+ is => 'rw',
+ isa => 'Date'
+ );
+
+ has_p date_as_time => (
+ isa => 'DateTime',
+ store_as => 'UnixTimestamp',
+ );
+
+ sub BUILD { shift->created_at(time) }
+ before save => sub { shift->updated_at(time) };
+}
+
+
+# fixture
+Coat::Persistent->map_to_dbi('csv', 'f_dir=./t/csv-test-database');
+
+my $dbh = Person->dbh;
+$dbh->do("CREATE TABLE people (pid INTEGER, birth_date CHAR(10), created_at CHAR(30), updated_at INTEGER, date_as_time INTEGER)");
+
+# TESTS
+
+my $p = Person->new( birth_date => '1983-02-06' );
+ok($p->save, '$p->save ');
+ok($p->created_at, 'created_at is defined');
+ok($p->updated_at, 'updated_at is defined');
+ok($p->created_at =~ /^\d+$/, 'created_at is an UnixTimestamp');
+is('Class::Date', ref $p->updated_at, 'updated_at is a Class::Date object');
+
+my $created_at_storage = $p->get_storage_value_for('created_at');
+my $updated_at_storage = $p->get_storage_value_for('updated_at');
+
+ok($created_at_storage =~ /\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d/, 'created_at_storage is a DateTime');
+ok($updated_at_storage =~ /^\d+$/, 'updated_at_storage is an UnixTimestamp');
+
+is('1983-02-06', $p->birth_date, 'birth_date is unchanged');
+
+# CLEAN
+$dbh->do("DROP TABLE people");
More information about the Pkg-perl-cvs-commits
mailing list