File Coverage

blib/lib/Class/Data/Localize.pm

Criterion	Covered	Total	%
statement	40	43	93.0
branch	11	12	91.6
condition	5	6	83.3
subroutine	7	7	100.0
pod			n/a
total	63	68	92.6

package Class::Data::Localize;

use strict qw(vars subs);
use vars qw($VERSION);
$VERSION = '0.03_2';

use ReleaseAction ();

our $warn_redefine = 1;

our %methods;
%methods = (
    'lazy_default' => sub {
        my ($declaredclass,$attr,$code) = @_;
        my $default;
        $default = sub {
            my $wantclass = ref($_[0]) || $_[0];
            $_[1] = $code->() unless defined $_[1];

            if(@_==3) {
               $_[2] = ReleaseAction->new(sub {
                   local $warn_redefine;
                   $methods{'make_accessor'}->($wantclass,$attr,$default);
               });
            }
            local $warn_redefine;
            $methods{'mk_classdata'}->($wantclass,$attr,$_[1]);
            shift;
            return $wantclass->$attr(@_);
        };
        return $default;
    },

    'class_accessor' => sub {
        my ($declaredclass, $attribute,$data) = @_;

        my $accessor;
        $accessor = sub {
            my $wantclass = ref($_[0]) || $_[0];
            if(@_==3) {
                my $current = $data;
                my $stacked = $_[2]; # maybe a lazy default release action
                $_[2] = ReleaseAction->new(sub {
                    $data = $current;
                    undef($stacked);
                });

                if($wantclass ne $declaredclass){
                    shift();
                    $methods{'mk_classdata'}->($wantclass,$attribute,$data);
                    return $wantclass->$attribute(@_);
                }
            }
            else {
                if(@_>1 && $wantclass ne $declaredclass) {
                    shift();
                    $methods{'mk_classdata'}->($wantclass,$attribute);
                    return $wantclass->$attribute(@_)
                }
            }
            $data = $_[1] if @_>1;
            return $data;
        };
        return $accessor;
    },

    'make_accessor' => sub {
        my ($declaredclass,$attribute,$accessor) = @_;

        my $alias = "_${attribute}_accessor";
        if($warn_redefine) {
            *{$declaredclass.'::'.$attribute} = $accessor;
            *{$declaredclass.'::'.$alias}     = $accessor;
        }
        else {
            no warnings 'redefine';
            *{$declaredclass.'::'.$attribute} = $accessor;
            *{$declaredclass.'::'.$alias}     = $accessor;
        }
    },

    'mk_classdata' => sub {
        my ($declaredclass, $attribute,@args) = @_;

        if( ref $declaredclass ) {
            require Carp;
            Carp::croak("mk_classdata() is a class method, not an object method");
        }
        my ($accessor);
        if(@args > 1) {
            my %args = @args;
            my $code = $args{'default'};

            $methods{'mk_classdata'}->($declaredclass, $attribute, undef);
            $accessor = $methods{'lazy_default'}->($declaredclass, $attribute, $code);
            local $warn_redefine;
            $methods{'make_accessor'}->($declaredclass,$attribute,$accessor)
        }
        else {
            $accessor = $methods{'class_accessor'}->($declaredclass, $attribute, $args[0]);
            $methods{'make_accessor'}->($declaredclass,$attribute,$accessor)
        }
    }
);

*mk_classdata = $methods{'mk_classdata'};

1;

__END__