Permalink
Browse files

First working version, YAY!

  • Loading branch information...
1 parent a04cf6c commit 98d3394aefa9f52aec4c604bfa0258a7479ea5ef @yannk committed Apr 20, 2009
View
@@ -9,6 +9,7 @@ build_requires 'Test::More';
requires 'Moose';
requires 'MooseX::Singleton';
requires 'Sub::Install';
+requires 'MooseX::AttributeHelpers';
test_requires 'Find::Lib';
test_requires 'Test::Exception';
View
@@ -45,7 +45,7 @@ couple your objects with their datastore(s).
$session->sync;
$pk = $user->pk;
- $user = $session->lookup($pk);
+ $user = $session->get(User => $pk);
is $user->first_name, "Yann";
=head1 DESCRIPTION
View
@@ -3,6 +3,11 @@ package Shrike::Deflator;
use warnings;
use strict;
+sub new {
+ my $class = shift;
+ return bless { }, $class;
+}
+
=head1 NAME
Shrike::Deflator - Base class for turning objects to flat hash suitable
@@ -1,4 +1,4 @@
-package Shrike::Deflator::InObject;
+package Shrike::Deflator::ObjectMethod;
use warnings;
use strict;
View
@@ -1,7 +1,8 @@
package Shrike::Driver::DBI;
-use Moose;
+use Carp;
use DBI;
+use Moose;
use YAML;
has table => ( is => 'ro', isa => 'Str' );
@@ -79,7 +80,11 @@ sub get {
## case of get_multi
sub get_multi {
my $driver = shift;
- my ($model_class, $pks) = @_;
+ my ($session, $model_class, $pks) = @_;
+
+ return [] unless $pks;
+ croak "get_multi should get a list of pk" unless ref $pks eq 'ARRAY';
+ croak "pks should be arrayref" unless ref $pks->[0] eq 'ARRAY';
my $dbh = $driver->dbh;
my $table = $driver->table;
@@ -89,6 +94,8 @@ sub get_multi {
# mysql
#my $stmt = "SELECT $columns FROM $table WHERE $pk IN ($IN)";
my @defined_pks = grep { defined } @$pks;
+ return [ @$pks ] unless scalar @defined_pks;
+
my $pk_where = '(' . ( join ' AND ', map { "$_ = ?" } @pk_col ) . ")";
my $pk_wheres = join ' OR ', ($pk_where) x scalar @defined_pks;
my $stmt = "SELECT $columns FROM $table WHERE $pk_wheres";
View
@@ -3,6 +3,11 @@ package Shrike::Inflator;
use warnings;
use strict;
+sub new {
+ my $class = shift;
+ return bless { }, $class;
+}
+
=head1 NAME
Shrike::Inflator - Base class for turning flat hash to objects
View
@@ -1,9 +1,88 @@
package Shrike::Map;
+use Carp;
use Moose;
-has driver => ( is => 'ro', isa => 'Shrike::Driver' );
-has inflator => ( is => 'ro', isa => 'Shrike::Inflator' );
-has delfator => ( is => 'ro', isa => 'Shrike::Deflator' );
+has class => ( is => 'ro', isa => 'Str' );
+has driver => ( is => 'ro', isa => 'Item' );
+has mapper => ( is => 'ro', isa => 'Shrike::Mapper', weak_ref => 1 );
+
+has inflator => (
+ is => 'ro',
+ isa => 'Shrike::Inflator',
+ handles => ['inflate'],
+);
+
+has deflator => (
+ is => 'ro',
+ isa => 'Shrike::Deflator',
+ handles => ['deflate'],
+);
+
+sub get {
+ my $map = shift;
+ my ($session, $model_class, @args) = @_;
+ my $driver = $map->driver;
+ my $data = $driver->get(@_);
+ return unless $data;
+ return $map->inflate($data, $model_class);
+}
+
+sub get_multi {
+ my $map = shift;
+ my ($session, $model_class, @args) = @_;
+ my $driver = $map->driver;
+ my $data_list = $driver->get_multi(@_);
+ return [] unless $data_list;
+ my $inflator = $map->inflator;
+ my $inflate = $inflator->can('inflate');
+ croak "Can't inflate because I don't have an inflator" unless $inflate;
+ return [ map { $inflate->($inflator, $_, $model_class) } @$data_list ];
+}
+
+sub insert {
+ my $map = shift;
+ my ($session, $model, @args) = @_;
+ my $data = $map->deflate($model)
+ or croak "Cannot deflate $model";
+ my $model_class = ref $model;
+ my $pk = $model->pk;
+ return $map->driver->insert($model_class, $data, $pk);
+}
+
+sub replace {
+ my $map = shift;
+ my ($session, $model, @args) = @_;
+ my $data = $map->deflate($model)
+ or croak "Cannot deflate $model";
+ my $model_class = ref $model;
+ my $pk = $model->pk;
+ return $map->driver->replace($model_class, $data, $pk);
+}
+
+## XXX dilemna on update,
+## though it's fine for some driver to do attribute changes (dbi)
+## it might not be the case for others (memcached), which stratgy to choose?
+## - take the cost of deflating?
+## - take the cost of fetching the data in the cache and update it?
+## simple solution, update() = delete of the cache key. Should be
+## configurable.
+sub update {
+ my $map = shift;
+ my ($session, $model, @args) = @_;
+ my $data = $map->deflate($model)
+ or croak "Cannot deflate $model";
+ my $model_class = ref $model;
+ my $pk = $model->pk;
+ return $map->driver->update($model_class, $data, $pk);
+}
+
+sub delete {
+ my $map = shift;
+ my ($session, $model, @args) = @_;
+ my $model_class = ref $model;
+ my $pk = $model->pk;
+ return $map->driver->delete($model_class, $pk);
+}
no Moose;
1;
View
@@ -1,7 +1,23 @@
package Shrike::Mapper;
+use Carp;
use Moose;
-
-has maps => ( is => 'rw', isa => 'HashRef[Shrike::Map]' );
+use MooseX::AttributeHelpers;
+use Shrike::Map;
+use Sub::Install;
+
+has maps => (
+ metaclass => 'Collection::Hash',
+ is => 'rw',
+ isa => 'HashRef[Shrike::Map]',
+ default => sub { {} },
+ provides => {
+ exists => 'has_map_for',
+ #keys => 'all_maps',
+ get => 'map_for',
+ set => 'set_map_for',
+ delete => 'remove_map_for',
+ }
+);
=head1 NAME
@@ -29,7 +45,78 @@ of transformation: C<$inflator> and C<$deflator>
=cut
sub map {
+ my $mapper = shift;
+ my ($model_class, $driver, $inflator, $deflator) = @_;
+
+ croak "There is already a map for $model_class"
+ if $mapper->has_map_for($model_class);
+
+ my $meta = $model_class->can('meta')
+ or croak "There is no meta for $model_class";
+
+ my $meta_class = $meta->($model_class);
+ my %attributes = %{ $meta_class->get_attribute_map };
+ for (keys %attributes) {
+ $meta_class->add_after_method_modifier(
+ $_ => $mapper->after_has_changed($_)
+ );
+ }
+ $mapper->export_methods($model_class, $driver);
+ my $map = Shrike::Map->new(
+ class => $model_class,
+ driver => $driver,
+ inflator => $inflator,
+ deflator => $deflator,
+ mapper => $mapper, # used?
+ );
+ $mapper->set_map_for($model_class => $map);
+ return $map;
+}
+
+sub after_has_changed {
+ my $mapper = shift;
+ my $attr = shift;
+ return sub {
+ my $instance = shift;
+ return unless @_;
+ my $value = shift;
+ warn "Changing $instance $attr to '$value'";
+ ## need to clean up after the end of the session
+ my $session = $instance->{__shrike_session};
+ if ($session) {
+ $session->mark_as_dirty($instance, $attr);
+ }
+ else {
+ warn "Object is probably not mapped yet";
+ }
+ return;
+ }
+}
+sub export_methods {
+ my $class = shift;
+ my ($model_class, $driver) = @_;
+
+ my $pk = sub {
+ my $model = shift;
+ if (@_) {
+ $model->{__pk} = shift;
+ }
+ return $model->{__pk} || [];
+
+ };
+ Sub::Install::install_sub({
+ code => $pk,
+ into => $model_class,
+ as => 'pk',
+ });
+ Sub::Install::install_sub({
+ code => sub {
+ return join ":", @{ shift->pk || [] };
+ },
+ into => $model_class,
+ as => 'pk_str',
+ });
}
=head1 AUTHOR
Oops, something went wrong.

0 comments on commit 98d3394

Please sign in to comment.