File Coverage

blib/lib/accessors.pm

Criterion	Covered	Total	%
statement	41	41	100.0
branch	12	14	85.7
condition			n/a
subroutine	13	13	100.0
pod	0	6	0.0
total	66	74	89.1

=head1 NAME

accessors - create accessor methods in caller's package.

=head1 SYNOPSIS

  package Foo;
  use accessors qw( foo bar baz );

  my $obj = bless {}, 'Foo';

  # generates chaining accessors
  # that you can set like this:
  $obj->foo( 'hello ' )
      ->bar( 'world' )
      ->baz( "!\n" );

  # you get the values by passing no params:
  print $obj->foo, $obj->bar, $obj->baz;

=cut

package accessors;

use 5.006;
use strict;
use warnings::register;

our $VERSION  = '1.01';
our $REVISION = (split(/ /, ' $Revision: 1.22 $ '))[2];

our $Debug        = 0;
our $ExportLevel  = 0;
our @InvalidNames = qw( BEGIN CHECK INIT END DESTROY AUTOLOAD );

use constant style => 'chained';

sub import {
    my $class   = shift;
    my $callpkg = caller( $class->ExportLevel );

    my @properties = @_ or return;

    $class->create_accessors_for( $callpkg, @properties );
}

sub create_accessors_for {
    my $class   = shift;
    my $callpkg = shift;

    warn( 'creating ' . $class->style . ' accessors( ',
	  join(' ',@_)," ) in pkg '$callpkg'" ) if $class->Debug;

    foreach my $property (@_) {
	my $accessor = "$callpkg\::$property";
	die( "can't create $accessor - '$property' is not a valid name!" )
	  unless $class->isa_valid_name( $property );
	warn( "creating " . $class->style . " accessor: $accessor\n" ) if
	  $class->Debug > 1;
	$class->create_accessor( $accessor, $property );
    }

    return $class;
}

sub create_accessor {
    my ($class, $accessor, $property) = @_;
    $property = "-$property";
    # set/get is slightly faster if we eval instead of using a closure + anon
    # sub, but the difference is marginal (~5%), and this uses less memory...
    no strict 'refs';
    *{$accessor} = sub {
	(@_ > 1)
	  ? ($_[0]->{$property} = $_[1], return $_[0])
	  : $_[0]->{$property};
    };
}

sub isa_valid_name {
    my ($class, $property) = @_;
    return unless $property =~ /^(?!\d)\w+$/;
    return if grep {$property eq $_} $class->InvalidNames;
    return 1;
}

##
## on the off-chance that someone will sub-class:
##

## don't like studly caps for sub-names, but stick with Exporter-like style...
sub Debug        { $Debug; }
sub ExportLevel  { $ExportLevel }
sub InvalidNames { @InvalidNames }

1;

__END__