File Coverage

blib/lib/Attribute/Property.pm

Criterion	Covered	Total	%
statement	34	67	50.7
branch	7	32	21.8
condition	0	3	0.0
subroutine	10	19	52.6
pod	0	2	0.0
total	51	123	41.4

package Attribute::Property;

# $Id: Property.pm,v 1.48 2003/04/21 16:04:14 juerd Exp $

use 5.006;
use Attribute::Handlers;
use Carp;

# use Want qw(want rreturn);
BEGIN {
    if (eval { require Want }) {
        *want    = *Want::want;
        *rreturn = *Want::rreturn;
    } else {
        *want    = sub { 0 };
        *rreturn = sub { 0 };
    }
}

no strict;
no warnings;

our $VERSION = '1.05';

$Carp::Internal{Attribute::Handlers}++;	 # may we be forgiven for our sins
$Carp::Internal{+__PACKAGE__}++;

my %p;

sub UNIVERSAL::Property : ATTR(CODE) {
    my (undef, $s, $r) = @_;
    croak "Cannot use Property attribute with anonymous sub" unless ref $s;
    my $n = *$s{NAME};
    *$s = defined &$s
        ? sub : lvalue {
            croak "Too many arguments for $n method" if @_ > 2;
            if (want 'RVALUE') {
                rreturn $_[0]{$n} if @_ != 2;
                $r->($_[0], local $_ = $_[1])
                    or croak "Invalid value for $n property";
                rreturn $_[0]{$n} = $_;
            }
            tie my $foo, __PACKAGE__, ${ \$_[0]{$n} }, $r, $_[0], $n;
            @_ == 2 ? ( $foo = $_[1] ) : $foo
        }
        : sub : lvalue {
            croak "Too many arguments for $n method" if @_ > 2;
            @_ == 2 ? ( $_[0]{$n} = $_[1] ) : ${ \$_[0]{$n} }
        };
    undef $p{\&$s};
}

sub TIESCALAR { bless \@_, shift }  # @_ = (class, lvalue, subref, object, name)
sub FETCH { $_[0][0] }

sub STORE {
    $_[0][1]->($_[0][2], local $_ = $_[1])
        or croak "Invalid value for $_[0][3] property";
    $_[0][0] = $_;
}

sub UNIVERSAL::New : ATTR(CODE) {
    my ($P, $s, $r) = @_;
    my $n = *$s{NAME};
    undef $r if not defined &$s;
    *$s = sub {
        my $c = shift;
        croak qq(Can't call method "$n" on a reference) if ref $c;
        croak "Odd number of arguments for $c->$n" if @_ % 2;
        my $o = bless {}, $c;
        my $l = \&Carp::shortmess;
        local *Carp::shortmess = sub { $_[-1] .= " in $c->$n"; &$l; };
        while (my ($p, $v) = splice @_, 0, 2) {
            my $m = $o->can($p);
            $m and exists $p{$m} or croak qq(No such property "$p");
            $m->($o, $v);
        }
        return $r->($o) if $r;
        return $o;
    };
}

1;

=head1 NAME

Attribute::Property - Easy lvalue accessors with validation. ($foo->bar = 42)

=head1 SYNOPSIS

=head2 CLASS

    use Attribute::Property;
    use Carp;

    package SomeClass;

    sub new : New { further initialization here ... }

    sub nondigits : Property { /^\D+\z/ }
    sub digits    : Property { /^\d+\z/ or croak "custom error message" }
    sub anyvalue  : Property;
    sub another   : Property;

    sub value     : Property {
	my $self = shift;  # Object is accessible as $_[0]
	s/^\s+//;          # New value can be altered through $_ or $_[1]

	$_ <= $self->maximum or croak "Value exceeds maximum";
    }

    package Person;

    sub new  : New;
    sub name : Property;
    sub age  : Property { /^\d+\z/ and $_ > 0 }

=head2 USAGE

    my $object = SomeClass->new(digits => '123');

    $object->nondigits = "abc";
    $object->digits    = "123";
    $object->anyvalue  = "abc123\n";

    $object->anyvalue('archaic style still works');

    my $john = Person->new(name => 'John Doe', age => 19);

    $john->age++;
    printf "%s is now %d years old", $john->name, $john->age;

    # These would croak
    $object->nondigits = "987";
    $object->digits    = "xyz";

=head1 DESCRIPTION

This module introduces two attributes that make object oriented programming
much easier.  You can just define a constructor and some properties without
having to write accessors.

=over 4

=item C

    sub color : Property;
    sub color : Property { /^#[0-9A-F]{6}$/ }

The C attribute turns a method into an object property.  The original
code block is used only to validate new values, the module croaks if it returns
false.  The method returns an I, meaning that you can create a reference
to it, assign to it and apply a regex to it.

Undefined subs (subs that have been declared but do not have a code block) with
the C attribute will be properties without any value validation.

In the validation code block, the object is in C<$_[0]> and the value to be
validated is aliased as C<$_[1]> and for regexing convenience as C<$_>.

Feel free to croak explicitly if you don't want the default error message.

=item C

    sub new : New;
    sub new : New { my $self = shift; ...; return $self; }

The C attribute turns a method into an object constructor.  The original
code block can be used for further initialization, but it is completely
optional.

The constructor takes named arguments in C<< property => value >> pairs and
populates the hash with the given pairs.  After validating them, of course.

The new object is passed to the initialization code block as C<$_[0]>.  Be
sure to return the object if you use any initialization block.  If there is
no initialization code block, Attribute::Property takes care of returning
the new object.

=back

=head1 PREREQUISITES

Your object must be a blessed hash reference.  The property names will be used
for the hash keys.

For class properties of C, the hash C<%Some::Module> is used.
For class properties of packages without C<::>, the behaviour is undefined.

In short: C<< $foo->bar = 14 >> and C<< $foo->bar(14) >> assign 14 to
C<< $foo->{bar} >> after positive validation.  The same thing happens with C<< my
$foo = Class->new(bar => 14); >> given that C uses the C
property.

If you have the Want module installed, Attribute::Property will use it to make
rvalue method calls more efficient.

=head1 COMPATIBILITY

Old fashioned C<< $object->property(VALUE) >> is still available.

This module requires a modern Perl (5.6.0+), fossils like Perl 5.00x don't
support our chicanery.

=head1 BUGS

=over 2

=item *

The C attribute should really be called C, but that would
conflict with the existing Attribute::Constructor module.

=back

=head1 LICENSE

There is no license.  This software was released into the public domain.  Do
with it what you want, but on your own risk.  Both authors disclaim any
responsibility.

=head1 AUTHORS

Juerd Waalboer

Matthijs van Duin

=cut

# vim: ft=perl sts=0 noet sw=8 ts=8