--- /dev/null
+0.00001_01 NODATEYET
+ -initial release
--- /dev/null
+Changes
+inc/Module/AutoInstall.pm
+inc/Module/Install.pm
+inc/Module/Install/AutoInstall.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/DBIx/Class/Schema/RestrictByUser.pm
+lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Schema.pm
+lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Source.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+t/02pod.t
+t/03podcoverage.t.disabled
+t/04basic.t
+t/05restrict.t
+t/lib/RestrictByUserTest.pm
+t/lib/RestrictByUserTest/Schema.pm
+t/lib/RestrictByUserTest/Schema/Notes.pm
+t/lib/RestrictByUserTest/Schema/Users.pm
--- /dev/null
+#! /usr/bin/perl -w
+
+# Load the Module::Install bundled in ./inc/
+use inc::Module::Install;
+
+# Define metadata
+name 'DBIx-Class-Schema-RestrictWithObject';
+abstract 'Restrict ResultSets';
+all_from 'lib/DBIx/Class/Schema/RestrictWithObject.pm';
+
+# Specific dependencies
+requires 'DBIx::Class' => 0.07000; ##just a safe number, no rhyme or reason
+
+build_requires 'Test::More' => 0;
+
+#ANYONE WANT TO GIVE ME VERSION NUMBERS??? PLEASE??
+build_requires 'SQL::Translator' => 0;
+build_requires 'Test::More' => 0;
+build_requires 'Scalar::Util' => 0;
+build_requires 'DBD::SQLite' => 0;
+
+auto_install;
+WriteAll;
--- /dev/null
+DBIx-Class-Schema-RestrictWithObject
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the perldoc command.
+
+ perldoc DBIx::Class::Schema::RestrictWithObject
+
+You can also look for information at:
+
+ Search CPAN
+ http://search.cpan.org/dist/DBIx-Class-Schema-RestrictWithObject
+
+ CPAN Request Tracker:
+ http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class-Schema-RestrictWithObject
+
+ AnnoCPAN, annotated CPAN documentation:
+ http://annocpan.org/dist/DBIx-Class-Schema-RestrictWithObject
+
+ CPAN Ratings:
+ http://cpanratings.perl.org/d/DBIx-Class-Schema-RestrictWithObject
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2007 Matt S Trout & Guillermo Roditi
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
--- /dev/null
+package DBIx::Class::Schema::RestrictByUser;
+
+our $VERSION = '0.0001_01';
+
+use DBIx::Class::Schema::RestrictByUser::RestrictComp::Schema;
+use DBIx::Class::Schema::RestrictByUser::RestrictComp::Source;
+
+# (c) Matt S Trout 2006, all rights reserved
+# this is free software under the same license as perl itself
+
+=head1 NAME
+
+DBIx::Class::Schema::RestrictByUser - Automatically restrict resultsets by user
+
+=head1 SYNOPSYS
+
+In your L<DBIx::Class::Schema> class:
+
+ __PACKAGE__->load_components(qw/Schema::RestrictByUser/);
+
+In the L<DBIx::Class> table class for your users:
+
+ #let's pretend a user has_many notes, which are in ResultSet 'Notes'
+ sub restrict_Notes_resultset {
+ my $self = shift; #the User object
+ my $unrestricted_rs = shift;
+
+ #restrict the notes viewable to only those that belong to this user
+ #this will, in effect make the following 2 equivalent
+ # $user->notes $schema->resultset('Notes')
+ return $self->related_resultset('notes');
+ }
+
+ #it could also be written like this
+ sub restrict_Notes_resultset {
+ my $self = shift; #the User object
+ my $unrestricted_rs = shift;
+ return $unrestricted_rs->search_rs( { user_id => $self->id } );
+ }
+
+Wherever you connect to your database
+
+ my $schema = MyApp::Schema->connect(...);
+ my $user = $schema->resultset('User')->find( { id => $user_id } );
+ $resticted_schema = $schema->restrict_by_user( $user, $optional_prefix);
+
+=cut
+
+=head1 DESCRIPTION
+
+This L<DBIx::Class::Schema> component can be used to restrict all resultsets through
+an appropriately-named method in a user's result_class. This can be done to
+automatically prevent data from being accessed by a user, effectively enforcing
+security by limiting any access to the data store.
+
+=head1 PUBLIC METHODS
+
+=head2 restrict_by_user $user_obj, $optional_prefix
+
+Will restrict resultsets according to the methods available in $user_obj and
+return a restricted copy of itself. ResultSets will be restricted if methods
+in the form of C<restrict_${ResultSet_Name}_resultset> are found in $user_obj.
+If the optional prefix is included it will attempt to use
+C<restrict_${prefix}_${ResultSet_Name}_resultset>, if that does not exist, it
+will try again without the prefix, and if that's not available the resultset
+will not be restricted.
+
+=cut
+
+sub restrict_by_user {
+ my ($self, $user, $prefix) = @_;
+ my $copy = $self->clone;
+ $copy->make_restricted;
+ $copy->user($user);
+ $copy->restricted_prefix($prefix) if $prefix;
+ return $copy;
+}
+
+=head1 PRIVATE METHODS
+
+=head2 make_restricted
+
+Restrict the Schema class and ResultSources associated with this Schema
+
+=cut
+
+sub make_restricted {
+ my ($self) = @_;
+ my $class = ref($self);
+ my $r_class = $self->_get_restricted_schema_class($class);
+ bless($self, $r_class);
+ foreach my $moniker ($self->sources) {
+ my $source = $self->source($moniker);
+ my $class = ref($source);
+ my $r_class = $self->_get_restricted_source_class($class);
+ bless($source, $r_class);
+ }
+}
+
+=head2 _get_restricted_schema_class $target_schema
+
+Return the class name for the restricted schema class;
+
+=cut
+
+sub _get_restricted_schema_class {
+ my ($self, $target) = @_;
+ return $self->_get_restricted_class(Schema => $target);
+}
+
+=head2 _get_restricted_source_class $target_source
+
+Return the class name for the restricted ResultSource class;
+
+=cut
+
+sub _get_restricted_source_class {
+ my ($self, $target) = @_;
+ return $self->_get_restricted_class(Source => $target);
+}
+
+=head2 _get_restrictedclass $type, $target
+
+Return an appropriate class name for a restricted class of type $type.
+
+=cut
+
+sub _get_restricted_class {
+ my ($self, $type, $target) = @_;
+ my $r_class = join('::', $target, '__RestrictedByUser');
+ unless (eval { $r_class->can('can') }) {
+ my $r_comp = join(
+ '::', 'DBIx::Class::Schema::RestrictByUser::RestrictComp', $type
+ );
+ $self->inject_base($r_class, $r_comp, $target);
+ }
+ return $r_class;
+}
+
+1;
+
+__END__;
+
+=head1 SEE ALSO
+
+L<DBIx::Class>, L<DBIx::Class::Schema::RestrictByUser::RestrictComp::Schema>,
+L<DBIx::Class::Schema::RestrictByUser::RestrictComp::Source>,
+
+=head1 AUTHORS
+
+Matt S Trout (mst) <mst@shadowcatsystems.co.uk>
+
+With contributions from
+Guillermo Roditi (groditi) <groditi@cpan.org>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package DBIx::Class::Schema::RestrictByUser::RestrictComp::Schema;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::AccessorGroup/;
+
+=head1 DESCRIPTION
+
+For general usage please see L<DBIx::Class::Schema::RestrictByUser>, the information
+provided here is not meant for general use and is subject to change. In the interest
+of transparency the functionality presented is documented, but all methods should be
+considered private and, as such, subject to incompatible changes and removal.
+
+=head1 ADDITIONAL ACCESSORS
+
+=head2 user
+
+Store the user object used to restict resultsets
+
+=head2 restricted_prefix
+
+Store the prefix, if any, to use when looking for the appropriate resstrict
+methods in the user object
+
+=cut
+
+__PACKAGE__->mk_group_accessors('simple' => 'user');
+__PACKAGE__->mk_group_accessors('simple' => 'restricted_prefix');
+
+1;
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::RestrictByUser>,
+
+=cut
--- /dev/null
+package DBIx::Class::Schema::RestrictByUser::RestrictComp::Source;
+
+use strict;
+use warnings;
+
+=head1 DESCRIPTION
+
+For general usage please see L<DBIx::Class::Schema::RestrictByUser>, the information
+provided here is not meant for general use and is subject to change. In the interest
+of transparency the functionality presented is documented, but all methods should be
+considered private and, as such, subject to incompatible changes and removal.
+
+=head1 PRIVATE METHODS
+
+=head2 resultset
+
+Intercept call to C<resultset> and return restricted resultset
+
+=cut
+
+sub resultset {
+ my $self = shift;
+ my $rs = $self->next::method(@_);
+ if (my $user = $self->schema->user) {
+ my $s = $self->source_name;
+ $s =~ s/::/_/g;
+ my $pre = $self->schema->restricted_prefix;
+ my $meth = "restrict_${s}_resultset";
+
+ if($pre){
+ my $meth_pre = "restrict_${pre}_${s}_resultset";
+ return $user->$meth_pre($rs) if $user->can($meth_pre);
+ }
+ $rs = $user->$meth($rs) if $user->can($meth);
+ }
+ return $rs;
+}
+
+1;
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::RestrictByUser>,
+
+=cut
--- /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();
--- /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 lib qw(t/lib);
+
+use_ok('DBIx::Class::Schema::RestrictByUser');
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+use Scalar::Util;
+
+plan (tests => 17);
+
+use lib qw(t/lib);
+
+use RestrictByUserTest;
+my $schema = RestrictByUserTest->init_schema;
+ok($schema, "Connected successfully");
+
+my $user1 = $schema->resultset('Users')->create({name => 'user1'});
+my $user2 = $schema->resultset('Users')->create({name => 'user2'});
+ok(ref $user1 && ref $user2, "Successfully created mock users");
+
+ok($user1->notes->create({name => 'note 1-1'}), "Successfully created 1-1 note");
+ok($user1->notes->create({name => 'note 1-2'}), "Successfully created 1-2 note");
+
+ok($user2->notes->create({name => 'note 2-1'}), "Successfully created 2-1 note");
+ok($user2->notes->create({name => 'note 2-2'}), "Successfully created 2-2 note");
+ok($user2->notes->create({name => 'note 2-3'}), "Successfully created 2-3 note");
+ok($user2->notes->create({name => 'note 2-4'}), "Successfully created 2-4 note");
+
+my $u1_schema = $schema->restrict_by_user($user1);
+my $u2_schema = $schema->restrict_by_user($user2, "MY");
+my $u3_schema = $schema->restrict_by_user($user2, "BUNK");
+
+is($u1_schema->user->id, $user1->id, "Correct restriction for user 1");
+is($u2_schema->user->id, $user2->id, "Correct restriction for user 2");
+is($u2_schema->restricted_prefix, "MY", "Correct prefix for user 2");
+
+ok(Scalar::Util::refaddr($u1_schema) ne Scalar::Util::refaddr($u2_schema),
+ "Successful clones");
+
+is($schema->resultset('Notes')->count, 6, 'Correct un resticted count');
+is($u1_schema->resultset('Notes')->count, 2, 'Correct resticted count');
+is($u2_schema->resultset('Notes')->count, 4, 'Correct resticted count using prefix');
+is($u2_schema->resultset('Notes')->count, 4,
+ 'Correct resticted count using prefix and fallback');
+
+is($u2_schema->resultset('Users')->count, 2, 'Unrestricted resultsets work');
+
+
+1;
--- /dev/null
+package # hide from PAUSE
+ RestrictByUserTest;
+
+use strict;
+use warnings;
+use RestrictByUserTest::Schema;
+
+sub init_schema {
+ my $self = shift;
+ my $db_file = "t/var/RestrictByUserTest.db";
+
+ unlink($db_file) if -e $db_file;
+ unlink($db_file . "-journal") if -e $db_file . "-journal";
+ mkdir("t/var") unless -d "t/var";
+
+ my $schema = RestrictByUserTest::Schema->connect( "dbi:SQLite:${db_file}");
+ $schema->deploy();
+ return $schema;
+}
+
+1;
--- /dev/null
+package # hide from PAUSE
+ RestrictByUserTest::Schema;
+
+use base qw/DBIx::Class::Schema/;
+
+__PACKAGE__->load_classes(qw/ Users Notes /);
+__PACKAGE__->load_components('Schema::RestrictByUser');
+
+1;
--- /dev/null
+package # hide from PAUSE
+ RestrictByUserTest::Schema::Notes;
+
+use base 'DBIx::Class';
+
+__PACKAGE__->load_components('Core');
+__PACKAGE__->table('notes_test');
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'int',
+ is_nullable => 0,
+ is_auto_increment => 1,
+ },
+ 'user_id' => {
+ data_type => 'int',
+ },
+ 'name' => {
+ data_type => 'varchar',
+ size => 100,
+ }
+);
+
+__PACKAGE__->set_primary_key('id');
+__PACKAGE__->belongs_to("user", "Users", { id => "user_id" });
+
+1;
--- /dev/null
+package # hide from PAUSE
+ RestrictByUserTest::Schema::Users;
+
+use base 'DBIx::Class';
+
+__PACKAGE__->load_components('Core');
+__PACKAGE__->table('test_users');
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'int',
+ is_nullable => 0,
+ is_auto_increment => 1,
+ },
+ 'name' => {
+ data_type => 'varchar',
+ size => 40,
+ }
+);
+
+__PACKAGE__->set_primary_key('id');
+__PACKAGE__->has_many("notes", "Notes", { "foreign.user_id" => "self.id" });
+
+sub restrict_Notes_resultset {
+ my $self = shift; #the User object
+ my $unrestricted_rs = shift;
+
+ return $self->related_resultset('notes');
+}
+
+sub restrict_MY_Notes_resultset {
+ my $self = shift; #the User object
+ my $unrestricted_rs = shift;
+
+ return $unrestricted_rs->search_rs( { user_id => $self->id } );
+}
+
+1;
projects / dbsrgits/DBIx-Class-Schema-RestrictWithObject.git / commitdiff