From: John Goulah <jgoulah@debian.org>
Date: Tue, 10 Jun 2008 16:07:44 +0000 (+0000)
Subject: initial checkin for UserStamp
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7bde90793dcc50d50b8dfc45e69001bf641d89d5;p=dbsrgits%2FDBIx-Class-UserStamp.git

initial checkin for UserStamp

git-svn-id: http://dev.catalyst.perl.org/repos/bast/DBIx-Class-UserStamp/1.000/trunk@4481 bd8105ee-0ff8-0310-8827-fb3f25b6796d
---

diff --git a/Changes b/Changes
new file mode 100644
index 0000000..296dddc
--- /dev/null
+++ b/Changes
@@ -0,0 +1,2 @@
+0.10    2008-06-09
+        - Initial release.
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..ddd9e15
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,18 @@
+use inc::Module::Install;
+
+name 'DBIx-Class-UserStamp';
+all_from 'lib/DBIx/Class/UserStamp.pm';
+
+requires 'DBIx::Class';
+
+build_requires 'Class::Accessor::Grouped';
+
+# generate README file
+if ($Module::Install::AUTHOR) {
+  system('pod2text lib/DBIx/Class/UserStamp.pm > README');
+}
+
+tests_recursive();
+auto_install;
+WriteAll;
+
diff --git a/lib/DBIx/Class/UserStamp.pm b/lib/DBIx/Class/UserStamp.pm
new file mode 100644
index 0000000..3115bbf
--- /dev/null
+++ b/lib/DBIx/Class/UserStamp.pm
@@ -0,0 +1,151 @@
+package DBIx::Class::UserStamp;
+
+use base qw(DBIx::Class);
+
+use warnings;
+use strict;
+
+our $VERSION = '0.10';
+
+__PACKAGE__->mk_classdata( 
+    '__column_userstamp_triggers' => {
+        on_update => [], on_create => []
+    }
+);
+
+=head1 NAME
+
+DBIx::Class::UserStamp - Automatically set update and create user id fields
+
+=head1 DESCRIPTION
+
+Automatically set fields on 'update' and 'create' that hold user id 
+values in a table. This can be used for any user id based  
+field that needs trigger like functionality when a record is 
+added or updated.
+
+=head1 SYNOPSIS
+
+ package MyApp::Schema;
+
+ __PACKAGE__->mk_group_accessors('simple' => qw/current_user_id/);
+
+
+ package MyApp::Model::MyAppDB;
+ use Moose;
+
+ around 'build_per_context_instance' => sub {
+   my ($meth, $self) = (shift, shift);
+   my ($c) = @_; # There are other params but we dont care about them
+   my $new = bless({ %$self }, ref($self));
+   my $user_info = $c->_user_in_session; 
+   my $user = $new->schema->resultset('User')->new_result({ %$user_info });
+   $new->schema->current_user_id($user->id) if (defined $user_info);
+   return $new;
+ };
+
+
+ package MyApp::Schema::SomeTable;
+
+ __PACKAGE__->load_components(qw( UserStamp ... Core ));
+ 
+ __PACKAGE__->add_columns(
+    id => { data_type => 'integer' },
+    u_created => { data_type => 'int', store_user_on_create => 1 },
+    u_updated => { data_type => 'int',
+        store_user_on_create => 1, store_user_on_update => 1 },
+ );
+
+Now, any update or create actions will update the specified columns with the
+current user_id, using the current_user_id accessor.  
+
+This is effectively trigger emulation to ease user id field insertion 
+
+=cut
+
+sub add_columns {
+    my $self = shift;
+
+    # Add everything else, get everything setup, and then process
+    $self->next::method(@_);
+   
+    my @update_columns = ();
+    my @create_columns = ();
+
+    foreach my $column ( $self->columns ) {
+        my $info = $self->column_info($column);
+        if ( $info->{store_user_on_update} ) {
+            push @update_columns, $column;
+        }
+        if ( $info->{store_user_on_create} ) {
+            push @create_columns, $column;
+        }
+    }
+    if ( @update_columns or @create_columns ) {
+        my $triggers = {
+            on_update => [ @update_columns ],
+            on_create => [ @create_columns ],
+        };
+        $self->__column_userstamp_triggers($triggers);
+    }
+}
+
+sub insert {
+    my $self  = shift;
+    my $attrs = shift;
+
+    my $user_id = $self->get_current_user_id;
+
+    my @columns = @{ $self->__column_userstamp_triggers()->{on_create} };
+
+    foreach my $column ( @columns ) {
+        next if defined $self->get_column( $column );
+        my $accessor = $self->column_info($column)->{accessor} || $column;
+        $self->$accessor($user_id);
+    }
+    
+    return $self->next::method(@_);
+}
+
+sub update {
+    my $self = shift;
+
+    my $user_id = $self->get_current_user_id;
+    my %dirty = $self->get_dirty_columns();
+    my @columns = @{ $self->__column_userstamp_triggers()->{on_update} };
+
+    foreach my $column ( @columns ) {
+        next if exists $dirty{ $column };
+        my $accessor = $self->column_info($column)->{accessor} || $column;
+        $self->$accessor($user_id);
+    }
+
+    return $self->next::method(@_);
+}
+
+=head1 METHODS
+
+=head2 get_current_user_id
+
+This method is meant to be overridden.  The default is to return a 
+schema accessor called current_user_id which should be populated as such.
+
+=cut
+sub get_current_user_id { shift->result_source->schema->current_user_id }
+
+=head1 AUTHOR
+
+ Matt S. Trout     <mst@shadowcatsystems.co.uk>
+
+=head1 CONTRIBUTOR 
+
+ John Goulah     <jgoulah@cpan.org>
+
+=head1 COPYRIGHT
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/t/01basic.t b/t/01basic.t
new file mode 100644
index 0000000..18b317c
--- /dev/null
+++ b/t/01basic.t
@@ -0,0 +1,13 @@
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+    eval "use DBD::SQLite";
+    plan $@
+        ? ( skip_all => 'needs DBD::SQLite for testing' )
+        : ( tests => 1 );
+}
+
+use_ok('DBIx::Class::UserStamp');
+
diff --git a/t/02pod.t b/t/02pod.t
new file mode 100644
index 0000000..ddc2905
--- /dev/null
+++ b/t/02pod.t
@@ -0,0 +1,6 @@
+use Test::More;
+
+eval "use Test::Pod 1.14";
+plan skip_all => 'Test::Pod 1.14 required' if $@;
+
+all_pod_files_ok();
diff --git a/t/03podcoverage.t b/t/03podcoverage.t
new file mode 100644
index 0000000..2d7ac1c
--- /dev/null
+++ b/t/03podcoverage.t
@@ -0,0 +1,8 @@
+use Test::More;
+
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@;
+plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD};
+
+all_pod_coverage_ok({ trustme => [ qw/add_columns insert update/ ] });
+
diff --git a/t/04userstamp.t b/t/04userstamp.t
new file mode 100644
index 0000000..864035a
--- /dev/null
+++ b/t/04userstamp.t
@@ -0,0 +1,30 @@
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+use lib qw(t/lib);
+use DBIC::Test;
+
+my $schema = DBIC::Test->init_schema;
+my $row;
+
+my $test_userid = '666';
+$schema->current_user_id($test_userid);
+
+$row = $schema->resultset('DBIC::Test::Schema::TestUser')
+    ->create({ display_name => 'test record' });
+
+ok $row->u_created, 'created userstamp';
+is $row->u_created, $test_userid, 'user id is correct';
+is $row->u_updated, $row->u_created, 'update and create userstamp are equal';
+
+# emulate some other user 
+my $test2_userid = '777';
+$schema->current_user_id($test2_userid);
+
+$row->display_name('test record again');
+$row->update;
+
+is $row->u_created, $test_userid, 'create only field isnt changed';
+is $row->u_updated, $test2_userid, 'update field is updated correctly';
diff --git a/t/05accessor.t b/t/05accessor.t
new file mode 100644
index 0000000..fab4ab8
--- /dev/null
+++ b/t/05accessor.t
@@ -0,0 +1,31 @@
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+use lib qw(t/lib);
+use DBIC::Test;
+
+my $schema = DBIC::Test->init_schema;
+my $row;
+
+my $test_userid = '666';
+$schema->current_user_id($test_userid);
+
+$row = $schema->resultset('DBIC::Test::Schema::Accessor')
+    ->create({ display_name => 'test record' });
+
+ok $row->u_created, 'created userstamp';
+is $row->u_created, $test_userid, 'user id is correct';
+is $row->u_updated, $row->u_created, 'update and create userstamp are equal';
+
+# emulate some other user 
+my $test2_userid = '777';
+$schema->current_user_id($test2_userid);
+
+$row->display_name('test record again');
+$row->update;
+
+is $row->u_created, $test_userid, 'create only field isnt changed';
+is $row->u_updated, $test2_userid, 'update field is updated correctly';
+
diff --git a/t/lib/DBIC/Test.pm b/t/lib/DBIC/Test.pm
new file mode 100644
index 0000000..b568643
--- /dev/null
+++ b/t/lib/DBIC/Test.pm
@@ -0,0 +1,109 @@
+package #
+    DBIC::Test;
+
+use strict;
+use warnings;
+
+BEGIN {
+    # little trick by Ovid to pretend to subclass+exporter Test::More
+    use base qw/Test::Builder::Module Class::Accessor::Grouped/;
+    use Test::More;
+    use File::Spec::Functions qw/catfile catdir/;
+    
+    @DBIC::Test::EXPORT = @Test::More::EXPORT;
+   
+    __PACKAGE__->mk_group_accessors('inherited', qw/db_dir db_file/);
+};
+
+__PACKAGE__->db_dir(catdir('t', 'var'));
+__PACKAGE__->db_file('test.db');
+
+sub init_schema {
+    my ( $self, %args ) = @_;
+
+    my $db_dir  = $args{'db_dir'}  || $self->db_dir;
+    my $db_file = $args{'db_file'} || $self->db_file;
+
+    my $namespace = $args{'namespace'} || 'DBIC::TestSchema';
+    my $db = catfile($db_dir, $db_file);
+
+    eval 'use DBD::SQLite';
+    if ( $@ ) {
+        BAIL_OUT('DBD::SQLite not installed');
+        return;
+    }
+
+    eval 'use DBIC::Test::Schema';
+    if ( $@ ) {
+        BAIL_OUT("Could not load test schema DBIC::Test::Schema: $@");
+        return;
+    }
+    
+    unlink($db) if -e $db;
+    unlink($db . '-journal') if -e $db . '-journal';
+    mkdir($db_dir) unless -d $db_dir;
+
+    my $dsn = 'dbi:SQLite:' . $db;
+    my $schema = DBIC::Test::Schema
+        ->compose_namespace($namespace)->connect($dsn);
+    $schema->storage->on_connect_do([
+        'PRAGMA synchronous = OFF',
+        'PRAGMA temp_store = MEMORY'
+    ]);
+
+    __PACKAGE__->deploy_schema($schema, %args);
+    __PACKAGE__->populate_schema($schema, %args) unless $args{'no_populate'};
+
+    return $schema;
+}
+
+sub deploy_schema {
+    my ( $self, $schema, %options ) = @_;
+    my $eval = $options{'eval_deploy'};
+
+    eval 'use SQL::Translator';
+
+    if ( !$@ && !$options{'no_deploy'} ) {
+        eval {
+            $schema->deploy();
+        };
+        if ( $@ && !$eval ) {
+            die $@;
+        }
+    } else {
+        unless ( open(IN, catfile('t', 'sql', 'test.sqlite.sql') ) ) {
+            BAIL_OUT("Can't load schema, sorry: $!");
+            return;
+        }
+        my $sql;
+        { local $/ = undef; $sql = <IN>; }
+        close IN;
+        eval {
+            ($schema->storage->dbh->do($_) || print "Error on SQL: $_\n")
+                for split(/;\n/, $sql);
+        };
+        if ( $@ && !$eval ) {
+            die $@;
+        }
+    }
+
+}
+
+sub clear_schema {
+    my ( $self, $schema, %options ) = @_;
+
+    foreach my $source ( $schema->sources ) {
+        $schema->resultset($source)->delete_all;
+    }
+}
+
+sub populate_schema {
+    my ( $self, $schema, %options ) = @_;
+
+    if ( $options{'clear'} ) {
+        $self->clear_schema($schema, %options);
+    }
+    # We don't need any data, but if we did, put it here.
+}
+
+1;
diff --git a/t/lib/DBIC/Test/Schema.pm b/t/lib/DBIC/Test/Schema.pm
new file mode 100644
index 0000000..faf6c72
--- /dev/null
+++ b/t/lib/DBIC/Test/Schema.pm
@@ -0,0 +1,16 @@
+package # hide from PAUSE
+    DBIC::Test::Schema;
+
+use base qw/DBIx::Class::Schema/;
+
+no warnings qw/qw/;
+
+__PACKAGE__->load_classes;
+
+__PACKAGE__->mk_group_accessors('simple' => qw/current_user_id/);
+
+sub dsn {
+    return shift->storage->connect_info->[0];
+}
+
+1;
diff --git a/t/lib/DBIC/Test/Schema/Accessor.pm b/t/lib/DBIC/Test/Schema/Accessor.pm
new file mode 100644
index 0000000..e5576ad
--- /dev/null
+++ b/t/lib/DBIC/Test/Schema/Accessor.pm
@@ -0,0 +1,43 @@
+package #
+    DBIC::Test::Schema::Accessor;
+
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->load_components(qw/UserStamp PK::Auto Core/);
+__PACKAGE__->table('test_accessor');
+
+__PACKAGE__->add_columns(
+    'pk1' => {
+        data_type => 'integer', is_nullable => 0, is_auto_increment => 1
+    },
+    display_name => { data_type => 'varchar', size => 128, is_nullable => 0 },
+    u_created => {
+        data_type => 'integer', is_nullable => 0,
+        store_user_on_create => 1, accessor => 'u_created_accessor',
+    },
+    u_updated => {
+        data_type => 'integer', is_nullable => 0,
+        store_user_on_create => 1, store_user_on_update => 1, accessor => 'u_updated_accessor',
+    },
+);
+
+__PACKAGE__->set_primary_key('pk1');
+
+no warnings 'redefine';
+
+sub u_created {
+    my $self = shift;
+    croak('Shouldnt be trying to update through u_created - should use accessor') if shift;
+
+    return $self->u_created_accessor();
+}
+
+sub u_updated {
+    my $self = shift;
+    croak('Shouldnt be trying to update through u_updated - should use accessor') if shift;
+
+    return $self->u_updated_accessor();
+}
+
+
+1;
diff --git a/t/lib/DBIC/Test/Schema/TestUser.pm b/t/lib/DBIC/Test/Schema/TestUser.pm
new file mode 100644
index 0000000..0241139
--- /dev/null
+++ b/t/lib/DBIC/Test/Schema/TestUser.pm
@@ -0,0 +1,26 @@
+package #
+    DBIC::Test::Schema::TestUser;
+
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->load_components(qw/UserStamp PK::Auto Core/);
+__PACKAGE__->table('test_user');
+
+__PACKAGE__->add_columns(
+    'pk1' => {
+        data_type => 'integer', is_nullable => 0, is_auto_increment => 1
+    },
+    display_name => { data_type => 'varchar', size => 128, is_nullable => 0 },
+    u_created => {
+        data_type => 'integer', is_nullable => 0,
+        store_user_on_create => 1
+    },
+    u_updated => {
+        data_type => 'integer', is_nullable => 0,
+        store_user_on_create => 1, store_user_on_update => 1
+    },
+);
+
+__PACKAGE__->set_primary_key('pk1');
+
+1;
diff --git a/t/sql/test.sqlite.sql b/t/sql/test.sqlite.sql
new file mode 100644
index 0000000..302ef01
--- /dev/null
+++ b/t/sql/test.sqlite.sql
@@ -0,0 +1,14 @@
+BEGIN TRANSACTION;
+CREATE TABLE test_user (
+  pk1 INTEGER PRIMARY KEY NOT NULL,
+  display_name varchar(128) NOT NULL,
+  u_created integer NOT NULL,
+  u_updated integer NOT NULL
+);
+CREATE TABLE test_accessor (
+  pk1 INTEGER PRIMARY KEY NOT NULL,
+  display_name varchar(128) NOT NULL,
+  u_created integer NOT NULL,
+  u_updated integer NOT NULL
+);
+COMMIT;
diff --git a/t/var/test.db b/t/var/test.db
new file mode 100644
index 0000000..634504d
Binary files /dev/null and b/t/var/test.db differ