File Coverage

blib/lib/Rubyish/Attribute.pm

Criterion	Covered	Total	%
statement	77	81	95.0
branch	10	12	83.3
condition			n/a
subroutine	21	21	100.0
pod	3	7	42.8
total	111	121	91.7

package Rubyish::Attribute;
use 5.010;

=head1 NAME

Rubyish::Attribute - ruby-like accessor builder: attr_accessor, attr_writer and attr_reader.

=cut

use Want;

sub import {
  my $caller = caller;
  for (qw(attr_accessor attr_reader attr_writer)) {
    *{$caller . "::" . $_} = *{$_};
  }
  eval qq{package $caller; use PadWalker qw(peek_my);};
}


=head1 VERSION

This document is for version 1.2

=cut

our $VERSION = "1.2";

=head1 SYNOPSIS

    #!/usr/bin/env perl

    use 5.010;

    use strict;
    use warnings;

    {
        package Animal;

        use Rubyish::Attribute;
        # import attr_accessor, attr_writer and attr_reader

        BEGIN {
          attr_accessor "name", "color", "type";
        }
        # pass a list as the only one parameter
        # invoke it in compile time to avoid using parenthesis when using instance variable as below

        # then create a constructer based on hashref
        sub new {
            $class = shift;
            bless {}, $class;
        }

        sub rename_as {
          my ($self, $new_name) = @_;
          __name__ = $new_name;

          # __name__ is accurately a lvalue subroutine &__name__() which refer to $self->{name}
          # now it looks like a instance variable.
        }

        1;
    }

    $dogy = Animal->new()->name("rock")
                  ->color("black")->type("unknown");
    # new Animal with three attribute

    say $dogy->name;  #=> rock
    say $dogy->color; #=> black
    say $dogy->type;  #=> unknown

=head1 FUNCTIONS

=head2 attr_accessor(@list)

attr_accessor provides getters double as setters.
Because all setter return instance itself, now we can manipulate object in ruby way more than ruby.

    attr_accessor qw(name color type master)
    $dogy = Animal->new()->name("lucky")->color("white")
                  ->type("unknown")->master("shelling");

Each attribute could be read by getter as showing in synopsis.

=cut


sub make_accessor {
    my $field = shift;
    return sub {
        my ($self, $arg) = @_;
        if ($arg) {
            $self->{$field} = $arg;
            $self;
        }
        else {
            $self->{$field};
        }
    }
}

sub attr_accessor {
    no strict;
    my $package = caller;
    for my $field (@_) {
        *{"${package}::${field}"} = make_accessor($field);
        make_instance_vars_accessor($package, $field);
    }
}

=head2 attr_reader(@list)

attr_reader create only getter for the class you call it

    attr_reader qw(name) # pass a list
    $dogy = Animal->new({name => "rock"}) # if we write initialize function in constructor
    $dogy->name()       #=> rock
    $dogy->name("jack") #=> undef (with warn msg)

=cut

sub make_reader {
    my $field = shift;
    return sub {
        my ($self, $arg) = @_;
        if ($arg) {
            warn "error - $field is only reader\n";
            return;             # because no writer
        }
        else {
            $self->{$field};
        }
    }
};

sub attr_reader {
    no strict;
    my $package = caller;
    for my $field (@_) {
        *{"${package}::${field}"} = make_reader($field);
        make_instance_vars_accessor($package, $field);
    }
}

=head2 attr_writer(@list)

attr_writer create only setter for the class you call it.

    attr_writer qw(name) # pass a list
    $dogy = Animal->new()->name("lucky") # initialize and set and get instance itself
    $dogy->name("jack") #=> instance itself
    $dogy->name         #=> undef (with warn msg)

=cut

sub make_writer {
    my $field = shift;
    return sub {
        my ($self, $arg) = @_;
        if ($arg) {
            $self->{$field} = $arg;
            $self;
        }
        else {
            warn "error - $field is only writer\n";
            return;             # because no reader
        }
    }
}

sub attr_writer {
    no strict;
    my $package = caller;
    for my $field (@_) {
        *{"${package}::${field}"} = make_writer($field);
        make_instance_vars_accessor($package, $field);
    }
}

sub make_instance_vars_accessor {
  no strict;
  my ($package, $field) = @_;
  eval qq|package $package;
    sub __${field}__ : lvalue {
      unless ( caller eq $package ) {
        require Carp;
        Carp::croak "__${field}__ is a protected method of $package!";
      }
      \${ peek_my(1)->{\'\$self\'} }->{$field};
    }
  |;
}

=head1 DEPENDENCE

L

=head1 SEE ALSO

L, L, L, L

L

L chinese introduction

=head1 AUTHOR

shelling

gugod

=head2 acknowledgement

Thanks to gugod providing testing script and leading me on the way of perl

=head1 REPOSITORY

host:       L

checkout:   git clone git://github.com/shelling/rubyish-attribute.git

=head1 BUGS

please report bugs to  or

=head1 COPYRIGHT & LICENCE

Copyright (C) 2008 shelling, gugod, all rights reserved.

Release under MIT (X11) Lincence.

=cut

1;