—
—
—
—
—
—
—
—
—
—
—

              
package DBIx::Class::AccessorGroup;
use strict;
use warnings;
use Carp::Clan qw/^DBIx::Class/;
HideShow 34 lines of Pod
=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) = @_;
  $self->_mk_group_accessors('make_group_accessor', $group, @fields);
  return;
}
{
    no strict 'refs';
    no warnings 'redefine';
    sub _mk_group_accessors {
        my($self, $maker, $group, @fields) = @_;
        my $class = ref $self || $self;
        # So we don't have to do lots of lookups inside the loop.
        $maker = $self->can($maker) unless ref $maker;
        foreach my $field (@fields) {
            if( $field eq 'DESTROY' ) {
                carp("Having a data accessor named DESTROY  in ".
                             "'$class' is unwise.");
            }
            my $name = $field;
            ($name, $field) = @$field if ref $field;
            my $accessor = $self->$maker($group, $field);
            my $alias = "_${name}_accessor";
            #warn "$class $group $field $alias";
            *{$class."\:\:$name"}  = $accessor;
              #unless defined &{$class."\:\:$field"}
            *{$class."\:\:$alias"}  = $accessor;
              #unless defined &{$class."\:\:$alias"}
        }
    }
}
HideShow 16 lines of Pod
=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);
}
HideShow 16 lines of Pod
=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);
}
HideShow 15 lines of Pod
=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) = @_;
    my $set = "set_$group";
    my $get = "get_$group";
    # Build a closure around $field.
    return sub {
        my $self = shift;
        if(@_) {
            return $self->$set($field, @_);
        }
        else {
            return $self->$get($field);
        }
    };
}
HideShow 15 lines of Pod
=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) = @_;
    my $get = "get_$group";
    return sub {
        my $self = shift;
        if(@_) {
            my $caller = caller;
            croak("'$caller' cannot alter the value of '$field' on ".
                        "objects of class '$class'");
        }
        else {
            return $self->$get($field);
        }
    };
}
HideShow 15 lines of Pod
=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) = @_;
    my $set = "set_$group";
    return sub {
        my $self = shift;
        unless (@_) {
            my $caller = caller;
            croak("'$caller' cannot access the value of '$field' on ".
                        "objects of class '$class'");
        }
        else {
            return $self->$set($field, @_);
        }
    };
}
HideShow 15 lines of Pod
=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};
}
HideShow 15 lines of Pod
=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;
}
HideShow 16 lines of Pod
=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;
  }
}
HideShow 16 lines of Pod
=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 (ref $self) {
      return $self->{$set} = $val;
  } else {
      $set = "_$set";
      return $self->can($set) ?
        $self->$set($val) :
        $self->mk_classdata($set => $val);
  }
}
1;
HideShow 10 lines of Pod
=head1 AUTHORS
Matt S. Trout <mst@shadowcatsystems.co.uk>
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut