X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FAccessorGroup.pm;h=56bcf1bb85649c3398d0b7ee6df6fde50660719a;hb=096f421241;hp=bfaef4d0b24907a051c5947c9fdecf4d53d7637c;hpb=b8e1e21f0fcd55e6e3ce987e57601b279a75b666;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm
index bfaef4d..56bcf1b 100644
--- a/lib/DBIx/Class/AccessorGroup.pm
+++ b/lib/DBIx/Class/AccessorGroup.pm
@@ -3,14 +3,47 @@ package DBIx::Class::AccessorGroup;
 use strict;
 use warnings;
 
-use base qw/Class::Data::Inheritable/;
+use Carp::Clan qw/^DBIx::Class/;
 
-__PACKAGE__->mk_classdata('_accessor_group_deleted' => { });
+=head1 NAME
+
+DBIx::Class::AccessorGroup -  Lets you build groups of accessors
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+This class lets you build groups of accessors that will call different
+getters and setters.
+
+=head1 METHODS
+
+=head2 mk_group_accessors
+
+=over 4
+
+=item Arguments: $group, @fieldspec
+
+Returns: none
+
+=back
+
+Creates a set of accessors in a given group.
+
+$group is the name of the accessor group for the generated accessors; they
+will call get_$group($field) on get and set_$group($field, $value) on set.
+
+@fieldspec is a list of field/accessor names; if a fieldspec is a scalar
+this is used as both field and accessor name, if a listref it is expected to
+be of the form [ $accessor, $field ].
+
+=cut
 
 sub mk_group_accessors {
-    my($self, $group, @fields) = @_;
+  my ($self, $group, @fields) = @_;
 
-    $self->_mk_group_accessors('make_group_accessor', $group, @fields);
+  $self->_mk_group_accessors('make_group_accessor', $group, @fields);
+  return;
 }
 
 
@@ -27,8 +60,7 @@ sub mk_group_accessors {
 
         foreach my $field (@fields) {
             if( $field eq 'DESTROY' ) {
-                require Carp;
-                &Carp::carp("Having a data accessor named DESTROY  in ".
+                carp("Having a data accessor named DESTROY  in ".
                              "'$class' is unwise.");
             }
 
@@ -50,18 +82,65 @@ sub mk_group_accessors {
     }
 }
 
+=head2 mk_group_ro_accessors
+
+=over 4
+
+=item Arguments: $group, @fieldspec
+
+Returns: none
+
+=back
+
+Creates a set of read only accessors in a given group. Identical to
+<L:/mk_group_accessors> but accessors will throw an error if passed a value
+rather than setting the value.
+
+=cut
+
 sub mk_group_ro_accessors {
     my($self, $group, @fields) = @_;
 
     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
 }
 
+=head2 mk_group_wo_accessors
+
+=over 4
+
+=item Arguments: $group, @fieldspec
+
+Returns: none
+
+=back
+
+Creates a set of write only accessors in a given group. Identical to
+<L:/mk_group_accessors> but accessors will throw an error if not passed a
+value rather than getting the value.
+
+=cut
+
 sub mk_group_wo_accessors {
     my($self, $group, @fields) = @_;
 
     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
 }
 
+=head2 make_group_accessor
+
+=over 4
+
+=item Arguments: $group, $field
+
+Returns: $sub (\CODE)
+
+=back
+
+Returns a single accessor in a given group; called by mk_group_accessors
+for each entry in @fieldspec.
+
+=cut
+
 sub make_group_accessor {
     my ($class, $group, $field) = @_;
 
@@ -81,6 +160,21 @@ sub make_group_accessor {
     };
 }
 
+=head2 make_group_ro_accessor
+
+=over 4
+
+=item Arguments: $group, $field
+
+Returns: $sub (\CODE)
+
+=back
+
+Returns a single read-only accessor in a given group; called by
+mk_group_ro_accessors for each entry in @fieldspec.
+
+=cut
+
 sub make_group_ro_accessor {
     my($class, $group, $field) = @_;
 
@@ -91,8 +185,7 @@ sub make_group_ro_accessor {
 
         if(@_) {
             my $caller = caller;
-            require Carp;
-            Carp::croak("'$caller' cannot alter the value of '$field' on ".
+            croak("'$caller' cannot alter the value of '$field' on ".
                         "objects of class '$class'");
         }
         else {
@@ -101,6 +194,21 @@ sub make_group_ro_accessor {
     };
 }
 
+=head2 make_group_wo_accessor
+
+=over 4
+
+=item Arguments: $group, $field
+
+Returns: $sub (\CODE)
+
+=back
+
+Returns a single write-only accessor in a given group; called by
+mk_group_wo_accessors for each entry in @fieldspec.
+
+=cut
+
 sub make_group_wo_accessor {
     my($class, $group, $field) = @_;
 
@@ -111,8 +219,7 @@ sub make_group_wo_accessor {
 
         unless (@_) {
             my $caller = caller;
-            require Carp;
-            Carp::croak("'$caller' cannot access the value of '$field' on ".
+            croak("'$caller' cannot access the value of '$field' on ".
                         "objects of class '$class'");
         }
         else {
@@ -121,13 +228,115 @@ sub make_group_wo_accessor {
     };
 }
 
-sub delete_accessor {
-  my ($class, $accessor) = @_;
-  $class = ref $class if ref $class;
-  my $sym = "${class}::${accessor}";
-  undef &$sym;
-  delete $DB::sub{$sym};
-  #$class->_accessor_group_deleted->{"${class}::${accessor}"} = 1;
+=head2 get_simple
+
+=over 4
+
+=item Arguments: $field
+
+Returns: $value
+
+=back
+
+Simple getter for hash-based objects which returns the value for the field
+name passed as an argument.
+
+=cut
+
+sub get_simple {
+  my ($self, $get) = @_;
+  return $self->{$get};
+}
+
+=head2 set_simple
+
+=over 4
+
+=item Arguments: $field, $new_value
+
+Returns: $new_value
+
+=back
+
+Simple setter for hash-based objects which sets and then returns the value
+for the field name passed as an argument.
+
+=cut
+
+sub set_simple {
+  my ($self, $set, $val) = @_;
+  return $self->{$set} = $val;
+}
+
+=head2 get_component_class
+
+=over 4
+
+=item Arguments: $name
+
+Returns: $component_class
+
+=back
+
+Returns the class name for a component; returns an object key if called on
+an object, or attempts to return classdata referenced by _$name if called
+on a class.
+
+=cut
+
+sub get_component_class {
+  my ($self, $get) = @_;
+  if (ref $self) {
+      return $self->{$get};
+  } else {
+      $get = "_$get";
+      return $self->can($get) ? $self->$get : undef;
+  }
+}
+
+=head2 set_component_class
+
+=over 4
+
+=item Arguments: $name, $new_component_class
+
+Returns: $new_component_class
+
+=back
+
+Sets a component class name; attempts to require the class before setting
+but does not error if unable to do so. Sets an object key of the given name
+if called or an object or classdata called _$name if called on a class.
+
+=cut
+
+sub set_component_class {
+  my ($self, $set, $val) = @_;
+  eval "require $val";
+  if ($@) {
+      my $val_path = $val;
+      $val_path =~ s{::}{/}g;
+      carp $@ unless $@ =~ /^Can't locate $val_path\.pm/;
+  }
+  if (ref $self) {
+      return $self->{$set} = $val;
+  } else {
+      $set = "_$set";
+      return $self->can($set) ?
+        $self->$set($val) :
+        $self->mk_classdata($set => $val);
+  }
 }
 
 1;
+
+=head1 AUTHORS
+
+Matt S. Trout <mst@shadowcatsystems.co.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+