package Class::Accessor::Lite::Lazy;
use strict;
use warnings;
use 5.008_001;
use parent 'Class::Accessor::Lite';
use Carp ();
our $VERSION = '0.03';
my %key_ctor = (
ro_lazy => \&_mk_ro_lazy_accessors,
rw_lazy => \&_mk_lazy_accessors,
);
sub import {
my ($class, %args) = @_;
my $pkg = caller;
foreach my $key (sort keys %key_ctor) {
if (defined (my $value = delete $args{$key})) {
Carp::croak "value of the '$key' parameter should be an arrayref or hashref"
unless ref($value) =~ /^(ARRAY|HASH)$/;
$value = [ $value ] if ref $value eq 'HASH';
$key_ctor{$key}->($pkg, @$value);
}
}
@_ = ($class, %args);
goto \&Class::Accessor::Lite::import;
}
sub mk_lazy_accessors {
(undef, my @properties) = @_;
my $pkg = caller;
_mk_lazy_accessors($pkg, @properties);
}
sub mk_ro_lazy_accessors {
(undef, my @properties) = @_;
my $pkg = caller;
_mk_ro_lazy_accessors($pkg, @properties);
}
sub _mk_ro_lazy_accessors {
my $pkg = shift;
my %decls = map { ref $_ eq 'HASH' ? ( %$_ ) : ( $_ => undef ) } @_;
no strict 'refs';
while (my ($name, $builder) = each %decls) {
*{"$pkg\::$name"} = __m_ro_lazy($pkg, $name, $builder);
}
}
sub _mk_lazy_accessors {
my $pkg = shift;
my %decls = map { ref $_ eq 'HASH' ? ( %$_ ) : ( $_ => undef ) } @_;
no strict 'refs';
while (my ($name, $builder) = each %decls) {
*{"$pkg\::$name"} = __m_lazy($name, $builder);
}
}
sub __m_ro_lazy {
my ($pkg, $name, $builder) = @_;
$builder = "_build_$name" unless defined $builder;
return sub {
if (@_ == 1) {
return $_[0]->{$name} if exists $_[0]->{$name};
return $_[0]->{$name} = $_[0]->$builder;
} else {
my $caller = caller(0);
Carp::croak("'$caller' cannot access the value of '$name' on objects of class '$pkg'");
}
};
}
sub __m_lazy {
my ($name, $builder) = @_;
$builder = "_build_$name" unless defined $builder;
return sub {
if (@_ == 1) {
return $_[0]->{$name} if exists $_[0]->{$name};
return $_[0]->{$name} = $_[0]->$builder;
} elsif (@_ == 2) {
return $_[0]->{$name} = $_[1];
} else {
return shift->{$name} = \@_;
}
};
}
1;
__END__
=head1 NAME
Class::Accessor::Lite::Lazy - Class::Accessor::Lite with lazy accessor feature
=head1 SYNOPSIS
package MyPackage;
use Class::Accessor::Lite::Lazy (
rw_lazy => [
# implicit builder method name is "_build_foo"
qw(foo foo2),
# or specify builder explicitly
{
xxx => 'method_name',
yyy => sub {
my $self = shift;
...
},
}
],
ro_lazy => [ qw(bar) ],
# Class::Accessor::Lite functionality is also available
new => 1,
rw => [ qw(baz) ],
);
# or if you specify all attributes' builders explicitly
use Class::Accessor::Lite::Lazy (
rw_lazy => {
foo => '_build_foo',
bar => \&_build_bar,
}
);
sub _build_foo {
my $self = shift;
...
}
sub _build_bar {
my $self = shift;
...
}
=head1 DESCRIPTION
Class::Accessor::Lite::Lazy provides a "lazy" accessor feature to L<Class::Accessor::Lite>.
If a lazy accessor without any value set is called, a builder method is called to generate a value to set.
=head1 THE USE STATEMENT
As L<Class::Accessor::Lite>, the use statement provides the way to create lazy accessors.
=over 4
=item rw_lazy => \@name_of_the_properties | \%properties_and_builders
Creates read / write lazy accessors.
=item ro_lazy => \@name_of_the_properties | \%properties_and_builders
Creates read-only lazy accessors.
=item new, rw, ro, wo
Same as L<Class::Accessor::Lite>.
=back
=head1 FUNCTIONS
=over 4
=item C<< Class::Accessor::Lite::Lazy->mk_lazy_accessors(@name_of_the_properties) >>
Creates lazy accessors in current package.
=item C<< Class::Accessor::Lite::Lazy->mk_ro_lazy_accessors(@name_of_the_properties) >>
Creates read-only lazy accessors in current package.
=back
=head1 SPECIFYING BUILDERS
As seen in SYNOPSIS, each attribute is specified by either a string or a hashref.
In the string form C<< $attr >> you specify builders implicitly, the builder method name for the attribute I<$attr> is named _build_I<$attr>.
In the hashref form C<< { $attr => $method_name | \&builder } >> you can explicitly specify builders, each key is the attribute name and each value is
either a string which specifies the builder method name or a coderef itself.
=head1 AUTHOR
motemen E<lt>motemen@gmail.comE<gt>
=head1 SEE ALSO
L<Class::Accessor::Lite>
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut