File Coverage

blib/lib/Class/Accessor/Class.pm

Criterion	Covered	Total	%
statement	43	43	100.0
branch	6	6	100.0
condition	1	3	33.3
subroutine	13	13	100.0
pod	4	4	100.0
total	67	69	97.1

use strict;
use warnings;
package Class::Accessor::Class 0.504;
use Class::Accessor 0.16 ();
use parent 'Class::Accessor';
# ABSTRACT: simple class variable accessors

#pod =head1 SYNOPSIS
#pod
#pod Set up a module with class accessors:
#pod
#pod  package Text::Fortune;
#pod
#pod  use base qw(Class::Accessor::Class Exporter);
#pod  Robot->mk_class_accessors(qw(language offensive collection));
#pod
#pod  sub fortune {
#pod    if (__PACKAGE__->offensive) {
#pod 	 ..
#pod
#pod Then, when using the module:
#pod
#pod  use Text::Fortune;
#pod
#pod  Text::Fortune->offensive(1);
#pod
#pod  print fortune; # prints an offensive fortune
#pod
#pod  Text::Fortune->language('EO');
#pod
#pod  print fortune; # prints an offensive fortune in Esperanto
#pod
#pod =head1 DESCRIPTION
#pod
#pod Class::Accessor::Class provides a simple way to create accessor and mutator
#pod methods for class variables, just as Class::Accessor provides for objects.  It
#pod can use either an enclosed lexical variable, or a package variable.
#pod
#pod This module was once implemented in terms of Class::Accessor, but changes to
#pod that module broke this relationship.  Class::Accessor::Class is still a
#pod subclass of Class::Accessor, strictly for historical reasons.  As a side
#pod benefit, a class that isa Class::Accessor::Class is also a Class::Accessor
#pod and can use its methods.
#pod
#pod =method mk_class_accessors
#pod
#pod  package Foo;
#pod  use base qw(Class::Accessor::Class);
#pod  Foo->mk_class_accessors(qw(foo bar baz));
#pod
#pod  Foo->foo(10);
#pod  my $obj = new Foo;
#pod  print $obj->foo;   # 10
#pod
#pod This method adds accessors for the named class variables.  The accessor will
#pod get or set a lexical variable to which the accessor is the only access.
#pod
#pod =cut

sub mk_class_accessors {
	my ($self, @fields) = @_;

  ## no critic (ProhibitNoStrict)
  no strict 'refs';
  for my $field (@fields) {
    *{"${self}::$field"} = $self->make_class_accessor($field);
  }
}

#pod =method mk_package_accessors
#pod
#pod  package Foo;
#pod  use base qw(Class::Accessor::Class);
#pod  Foo->mk_package_accessors(qw(foo bar baz));
#pod
#pod  Foo->foo(10);
#pod  my $obj = new Foo;
#pod  print $obj->foo;   # 10
#pod  print $Foo::foo;    # 10
#pod
#pod This method adds accessors for the named class variables.  The accessor will
#pod get or set the named variable in the package's symbol table.
#pod
#pod =cut

sub mk_package_accessors {
	my ($self, @fields) = @_;

  ## no critic (ProhibitNoStrict)
  no strict 'refs';
  for my $field (@fields) {
    *{"${self}::$field"} = $self->make_package_accessor($field);
  }
}

#pod =head1 DETAILS
#pod
#pod =head2 make_class_accessor
#pod
#pod  $accessor = Class->make_class_accessor($field);
#pod
#pod This method generates a subroutine reference which acts as an accessor for the
#pod named field.
#pod
#pod =cut

{
	my %accessor;

	sub make_class_accessor {
		my ($class, $field) = @_;

		return $accessor{$class}{$field}
			if $accessor{$class}{$field};

		my $field_value;

		$accessor{$class}{$field} = sub {
			my $class = shift;

			return @_
				? ($field_value = $_[0])
				:  $field_value;
		}
	}
}

#pod =head2 make_package_accessor
#pod
#pod  $accessor = Class->make_package_accessor($field);
#pod
#pod This method generates a subroutine reference which acts as an accessor for the
#pod named field, which is stored in the scalar named C in C's symbol
#pod table.
#pod
#pod This can be useful for dealing with legacy code, but using package variables is
#pod almost never a good idea for new code.  Use this with care.
#pod
#pod =cut

sub make_package_accessor {
	my ($self, $field) = @_;
	my $class = ref $self || $self;

	my $varname = "$class\:\:$field";
	return sub {
		my $class = shift;

    ## no critic (ProhibitNoStrict)
    no strict 'refs';
		return @_
			? (${$varname} = $_[0])
			:  ${$varname}
	}
}

1;

__END__