1 package DBIx::Class::Schema::RestrictByUser;
3 our $VERSION = '0.0001_01';
5 use DBIx::Class::Schema::RestrictByUser::RestrictComp::Schema;
6 use DBIx::Class::Schema::RestrictByUser::RestrictComp::Source;
8 # (c) Matt S Trout 2006, all rights reserved
9 # this is free software under the same license as perl itself
13 DBIx::Class::Schema::RestrictByUser - Automatically restrict resultsets by user
17 In your L<DBIx::Class::Schema> class:
19 __PACKAGE__->load_components(qw/Schema::RestrictByUser/);
21 In the L<DBIx::Class> table class for your users:
23 #let's pretend a user has_many notes, which are in ResultSet 'Notes'
24 sub restrict_Notes_resultset {
25 my $self = shift; #the User object
26 my $unrestricted_rs = shift;
28 #restrict the notes viewable to only those that belong to this user
29 #this will, in effect make the following 2 equivalent
30 # $user->notes $schema->resultset('Notes')
31 return $self->related_resultset('notes');
34 #it could also be written like this
35 sub restrict_Notes_resultset {
36 my $self = shift; #the User object
37 my $unrestricted_rs = shift;
38 return $unrestricted_rs->search_rs( { user_id => $self->id } );
41 Wherever you connect to your database
43 my $schema = MyApp::Schema->connect(...);
44 my $user = $schema->resultset('User')->find( { id => $user_id } );
45 $resticted_schema = $schema->restrict_by_user( $user, $optional_prefix);
51 This L<DBIx::Class::Schema> component can be used to restrict all resultsets through
52 an appropriately-named method in a user's result_class. This can be done to
53 automatically prevent data from being accessed by a user, effectively enforcing
54 security by limiting any access to the data store.
58 =head2 restrict_by_user $user_obj, $optional_prefix
60 Will restrict resultsets according to the methods available in $user_obj and
61 return a restricted copy of itself. ResultSets will be restricted if methods
62 in the form of C<restrict_${ResultSet_Name}_resultset> are found in $user_obj.
63 If the optional prefix is included it will attempt to use
64 C<restrict_${prefix}_${ResultSet_Name}_resultset>, if that does not exist, it
65 will try again without the prefix, and if that's not available the resultset
66 will not be restricted.
70 sub restrict_by_user {
71 my ($self, $user, $prefix) = @_;
72 my $copy = $self->clone;
73 $copy->make_restricted;
75 $copy->restricted_prefix($prefix) if $prefix;
79 =head1 PRIVATE METHODS
81 =head2 make_restricted
83 Restrict the Schema class and ResultSources associated with this Schema
89 my $class = ref($self);
90 my $r_class = $self->_get_restricted_schema_class($class);
91 bless($self, $r_class);
92 foreach my $moniker ($self->sources) {
93 my $source = $self->source($moniker);
94 my $class = ref($source);
95 my $r_class = $self->_get_restricted_source_class($class);
96 bless($source, $r_class);
100 =head2 _get_restricted_schema_class $target_schema
102 Return the class name for the restricted schema class;
106 sub _get_restricted_schema_class {
107 my ($self, $target) = @_;
108 return $self->_get_restricted_class(Schema => $target);
111 =head2 _get_restricted_source_class $target_source
113 Return the class name for the restricted ResultSource class;
117 sub _get_restricted_source_class {
118 my ($self, $target) = @_;
119 return $self->_get_restricted_class(Source => $target);
122 =head2 _get_restrictedclass $type, $target
124 Return an appropriate class name for a restricted class of type $type.
128 sub _get_restricted_class {
129 my ($self, $type, $target) = @_;
130 my $r_class = join('::', $target, '__RestrictedByUser');
131 unless (eval { $r_class->can('can') }) {
133 '::', 'DBIx::Class::Schema::RestrictByUser::RestrictComp', $type
135 $self->inject_base($r_class, $r_comp, $target);
146 L<DBIx::Class>, L<DBIx::Class::Schema::RestrictByUser::RestrictComp::Schema>,
147 L<DBIx::Class::Schema::RestrictByUser::RestrictComp::Source>,
151 Matt S Trout (mst) <mst@shadowcatsystems.co.uk>
153 With contributions from
154 Guillermo Roditi (groditi) <groditi@cpan.org>
158 You may distribute this code under the same terms as Perl itself.