lib/DBIx/Class/Schema/RestrictWithObject.pm

   1 package DBIx::Class::Schema::RestrictWithObject;
   2
   3 our $VERSION = '0.0001';
   4
   5 use DBIx::Class::Schema::RestrictWithObject::RestrictComp::Schema;
   6 use DBIx::Class::Schema::RestrictWithObject::RestrictComp::Source;
   7
   8 # (c) Matt S Trout 2006, all rights reserved
   9 # this is free software under the same license as perl itself
  10
  11 =head1 NAME
  12
  13 DBIx::Class::Schema::RestrictWithObject - Automatically restrict resultsets
  14
  15 =head1 SYNOPSYS
  16
  17 In your L<DBIx::Class::Schema> class:
  18
  19     __PACKAGE__->load_components(qw/Schema::RestrictWithObject/);
  20
  21 In the L<DBIx::Class> table class for your users:
  22
  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;
  27
  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');
  32     }
  33
  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 } );
  39     }
  40
  41 Wherever you connect to your database
  42
  43     my $schema = MyApp::Schema->connect(...);
  44     my $user = $schema->resultset('User')->find( { id => $user_id } );
  45     $resticted_schema = $schema->restrict_with_object( $user, $optional_prefix);
  46
  47 In this example we used the User object as the restricting object, but please
  48 note that the restricting object need not be a DBIC class, it can be any kind of
  49 object that provides the adequate methods.
  50
  51 =cut
  52
  53 =head1 DESCRIPTION
  54
  55 This L<DBIx::Class::Schema> component can be used to restrict all resultsets through
  56 an appropriately-named method in a user-supplied object. This allows you to
  57 automatically prevent data from being accessed, or automatically predefine options
  58 and search clauses on a schema-wide basis. When used to limit data sets, it allows
  59 simplified security by limiting any access to the data at the schema layer. Please
  60 note however that this is not a silver bullet and without careful programming it is
  61 still possible to expose unwanted data, so this should not be regarded as a
  62 replacement for application level security.
  63
  64 =head1 PUBLIC METHODS
  65
  66 =head2 restrict_with_object $restricting_obj, $optional_prefix
  67
  68 Will restrict resultsets according to the methods available in $restricting_obj and
  69 return a restricted copy of itself. ResultSets will be restricted if methods
  70 in the form  of C<restrict_${ResultSource_Name}_resultset> are found in
  71 $restricting_obj. If the optional prefix is included it will attempt to use
  72 C<restrict_${prefix}_${ResultSource_Name}_resultset>, if that does not exist, it
  73 will try again without the prefix, and if that's not available the resultset
  74 will not be restricted.
  75
  76 =cut
  77
  78 sub restrict_with_object {
  79   my ($self, $obj, $prefix) = @_;
  80   my $copy = $self->clone;
  81   $copy->make_restricted;
  82   $copy->restricting_object($obj);
  83   $copy->restricted_prefix($prefix) if $prefix;
  84   return $copy;
  85 }
  86
  87 =head1 PRIVATE METHODS
  88
  89 =head2 make_restricted
  90
  91 Restrict the Schema class and ResultSources associated with this Schema
  92
  93 =cut
  94
  95 sub make_restricted {
  96   my ($self) = @_;
  97   my $class = ref($self);
  98   my $r_class = $self->_get_restricted_schema_class($class);
  99   bless($self, $r_class);
 100   foreach my $moniker ($self->sources) {
 101     my $source = $self->source($moniker);
 102     my $class = ref($source);
 103     my $r_class = $self->_get_restricted_source_class($class);
 104     bless($source, $r_class);
 105   }
 106 }
 107
 108 =head2 _get_restricted_schema_class $target_schema
 109
 110 Return the class name for the restricted schema class;
 111
 112 =cut
 113
 114 sub _get_restricted_schema_class {
 115   my ($self, $target) = @_;
 116   return $self->_get_restricted_class(Schema => $target);
 117 }
 118
 119 =head2 _get_restricted_source_class $target_source
 120
 121 Return the class name for the restricted ResultSource class;
 122
 123 =cut
 124
 125 sub _get_restricted_source_class {
 126   my ($self, $target) = @_;
 127   return $self->_get_restricted_class(Source => $target);
 128 }
 129
 130 =head2 _get_restrictedclass $type, $target
 131
 132 Return an appropriate class name for a restricted class of type $type.
 133
 134 =cut
 135
 136 sub _get_restricted_class {
 137   my ($self, $type, $target) = @_;
 138   my $r_class = join('::', $target, '__RestrictedWithObject');
 139   my $r_comp = join(
 140     '::', 'DBIx::Class::Schema::RestrictWithObject::RestrictComp', $type
 141   );
 142   unless ($r_class->isa($r_comp)) {
 143     $self->inject_base($r_class, $r_comp, $target);
 144   }
 145   return $r_class;
 146 }
 147
 148 1;
 149
 150 __END__;
 151
 152 =head1 SEE ALSO
 153
 154 L<DBIx::Class>, L<DBIx::Class::Schema::RestrictWithObject::RestrictComp::Schema>,
 155 L<DBIx::Class::Schema::RestrictWithObject::RestrictComp::Source>,
 156
 157 =head1 AUTHORS
 158
 159 Matt S Trout (mst) <mst@shadowcatsystems.co.uk>
 160
 161 With contributions from
 162 Guillermo Roditi (groditi) <groditi@cpan.org>
 163
 164 =head1 LICENSE
 165
 166 You may distribute this code under the same terms as Perl itself.
 167
 168 =cut