--- /dev/null
+0.10 2008-06-09
+ - Initial release.
--- /dev/null
+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;
+
--- /dev/null
+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;
--- /dev/null
+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');
+
--- /dev/null
+use Test::More;
+
+eval "use Test::Pod 1.14";
+plan skip_all => 'Test::Pod 1.14 required' if $@;
+
+all_pod_files_ok();
--- /dev/null
+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/ ] });
+
--- /dev/null
+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';
--- /dev/null
+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';
+
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
projects / dbsrgits/DBIx-Class-UserStamp.git / commitdiff