File Coverage

lib/Class/Dot.pm

Criterion	Covered	Total	%
statement	206	208	99.0
branch	45	50	90.0
condition	10	14	71.4
subroutine	39	39	100.0
pod	4	4	100.0
total	304	315	96.5

# $Id: Dot.pm 47 2007-11-03 21:11:17Z asksol $
# $Source: /opt/CVS/Getopt-LL/lib/Class/Dot.pm,v $
# $Author: asksol $
# $HeadURL: https://class-dot.googlecode.com/svn/branches/stable-1.5.0/lib/Class/Dot.pm $
# $Revision: 47 $
# $Date: 2007-11-03 22:11:17 +0100 (Sat, 03 Nov 2007) $
package Class::Dot;

use strict;
use warnings;
use version qw(qv);
use 5.006000;

use Carp qw(croak);
use Class::Dot::Types qw(:std);

our $VERSION   = qv('1.5.0');
our $AUTHORITY = 'cpan:ASKSH';

my @EXPORT_OK = qw(
    property after_property_set after_property_get
);

push @EXPORT_OK, @Class::Dot::Types::STD_TYPES;

my $INTERNAL_ATTR_NOISE = '__x__';

my %EXPORT_CLASS = (
   ':std'  => [@EXPORT_OK],
);

our %OPTIONS_FOR     = ();
our %PROPERTIES_FOR  = ();

my %__TYPE_DICT__ = (
   'Array'     => \&isa_Array,
   'Code'      => \&isa_Code,
   'Data'      => \&isa_Data,
   'File'      => \&isa_File,
   'Hash'      => \&isa_Hash,
   'Int'       => \&isa_Int,
   'Object'    => \&isa_Object,
   'String'    => \&isa_String,
);

sub import { ## no critic
    my $this_class   = shift;
    my $caller_class = caller;

    my $options = { };
    my $export_class;
    my @subs;
    for my $arg (@_) {
        if ($arg =~ m/^-/xms) {
            $options->{$arg} = 1;
        }
        elsif ($arg =~ m/^:/xms) {
            croak(   'Only one export class can be used. '
                    ."(Used already: [$export_class] now: [$arg])")
                if $export_class;

            $export_class = $arg;
        }
        else {
            push @subs, $arg;
        }
    }
    $OPTIONS_FOR{$caller_class} = $options;

    my @subs_to_export
        = $export_class && $EXPORT_CLASS{$export_class}
        ? (@{ $EXPORT_CLASS{$export_class} }, @subs)
        : @subs;

    no strict 'refs'; ## no critic;
    for my $sub_to_export (@subs_to_export) {
        _install_sub_from_class($this_class, $sub_to_export => $caller_class);
    }


    my %INSTALL_METHOD = (
        DESTROY     => _create_destroy_method($caller_class),
        __setattr__ => _create_setattr($caller_class),
        __getattr__ => _create_getattr($caller_class),
        __hasattr__ => _create_hasattr($caller_class),
    );
    if ($options->{'-new'}) {
        $INSTALL_METHOD{'new'} = _create_constructor($caller_class);
    }

    while (my ($method_name, $method_ref) = each %INSTALL_METHOD) {
        _install_sub_from_coderef($method_ref => $caller_class, $method_name);
    }

    $PROPERTIES_FOR{$caller_class} = {};

    return;
}

sub _install_sub_from_class {
    my ($pkg_from, $sub_name, $pkg_to) = @_;
    my $from = join q{::}, ($pkg_from, $sub_name);
    my $to   = join q{::}, ($pkg_to,   $sub_name);

    no strict 'refs'; ## no critic
    *{$to} = *{$from};

    return;
}

sub _install_sub_from_coderef {
    my ($coderef, $pkg_to, $sub_name) = @_;
    my $to = join q{::}, ($pkg_to, $sub_name);

    no strict   'refs';     ## no critic
    no warnings 'redefine'; ## no critic
    *{$to} = $coderef;

    return;
}

sub _create_setattr {
	my ($caller_class) = @_;
	my $options = $OPTIONS_FOR{$caller_class};

	return sub {
		my ($self, $attribute, $value) = @_;
        my $property_key
            = $INTERNAL_ATTR_NOISE . $attribute .  $INTERNAL_ATTR_NOISE;
		my $properties = __PACKAGE__->properties_for_class($self);
		return if not $properties->{$attribute};
		$self->{$property_key} = $value;
		return 1;
	}
}

sub _create_getattr {
	my ($caller_class) = @_;

	return sub {
		my ($self, $attribute) = @_;
        my $property_key
            = $INTERNAL_ATTR_NOISE . $attribute .  $INTERNAL_ATTR_NOISE;
		my $properties = __PACKAGE__->properties_for_class($self);
		return if not $properties->{$attribute};
		return $self->{$property_key};
	}
}

sub _create_hasattr {
	my ($caller_class) = @_;

    # For some reason, perlcritic thinks 'return sub {)'
    # is ProhibitMixedBooleanOperators, so need no critic here.
	return sub { ## no critic
		my ($self, $attribute) = @_;
        my $ref_self = ref $self;

        my $class;
        if ($ref_self) {
            $class = $ref_self;
        }
        else {
            $class = $self;
        }

        no strict 'refs'; ## no critic;
        my  @isa = @{ "${class}::ISA" };
        my $has_property = 0;

        ISA:
        for my $isa ($class, @isa) {
            if ($PROPERTIES_FOR{$isa} && $PROPERTIES_FOR{$isa}{$attribute}) {
                $has_property = 1;
                last ISA;
            }
        }

		return if not $has_property;
		return 1;
	}
}


sub _create_constructor {
    my ($caller_class) = @_;
    my $options = $OPTIONS_FOR{$caller_class};

    return sub {
        my ($class, $options_ref) = @_;
        $options_ref ||= {};

        my $self = { };
        bless $self, $class;

        OPTION:
        while (my ($opt_key, $opt_value) = each %{$options_ref}) {

            if ($self->__hasattr__($opt_key)) {
                $self->__setattr__($opt_key, $opt_value);
            }
        }

        no strict 'refs'; ## no critic
        if (my $build_ref = *{ $class . '::BUILD' }{CODE}) { ## no critic
            $Carp::CallLevel++; ## no critic
            my $ret = $build_ref->($self, $options_ref);
            $Carp::CallLevel--; ## no critic
            if ($options->{'-rebuild'} && ref $ret) {
                $self = $ret;
            }
        }

        return $self;
        }
}

sub properties_for_class {
    my ($self, $class) = @_;
    $class = ref $class || $class; ## no critic

    my %class_properties;

    my @isa_for_class;
    {
        no strict 'refs'; ## no critic
        @isa_for_class = @{ $class . '::ISA' };
    }

    for my $parent ($class, @isa_for_class) {
        for my $parent_property (keys %{ $PROPERTIES_FOR{$parent} }) {
            $class_properties{$parent_property} = 1;
        }
    }

    return \%class_properties;
}

sub _create_destroy_method {
    my ($caller_class) = @_;

    return sub {
        my ($self) = @_;
        #my $properties_ref =$PROPERTIES_FOR{$caller_class};
        #undef %{$properties_ref};
        #delete $PROPERTIES_FOR{$caller_class};

        no strict   'refs'; ## no critic
        no warnings 'once'; ## no critic
        if (my $demolish_ref = *{$caller_class.'::DEMOLISH'}{CODE}) { ## no critic
            $demolish_ref->($self);
        }

        return;
    }
}

sub property (@) { ## no critic
    my ($property, $isa) = @_;
    return if not $property;

    my $caller_class = caller;
    my $set_property = "set_$property";


    no strict 'refs'; ## no critic
    if (not *{ $caller_class . "::$property" }{CODE}) {
        my $get_accessor = _create_get_accessor($caller_class, $property, $isa);
        _install_sub_from_coderef($get_accessor => $caller_class, $property);
    }

    if (not *{ $caller_class . "::$set_property" }{CODE}) {
        my $set_accessor = _create_set_accessor($caller_class, $property, $isa);
        _install_sub_from_coderef($set_accessor => $caller_class, $set_property);
    }

    $PROPERTIES_FOR{$caller_class}->{$property} = 1;

    return;
}

sub after_property_get (@&) { ## no critic
    my ($property, $func_ref) = @_;
    my $caller_class = caller;

    _install_sub_from_coderef($func_ref => $caller_class, $property);

    return;
}

sub after_property_set (@&) { ## no critic
    my ($property, $func_ref) = @_;
    my $caller_class = caller;
    my $set_property = "set_$property";

    _install_sub_from_coderef($func_ref => $caller_class, $set_property);

    return;
}

sub _create_get_accessor {
    my ($caller_class, $property, $isa) = @_;
    my $options = $OPTIONS_FOR{$caller_class};
    my $property_key
        = $INTERNAL_ATTR_NOISE . $property .  $INTERNAL_ATTR_NOISE;

    if ($options->{'-chained'}) {
        return sub {
            my $self = shift;
            if (@_) {
                my $set_property = "set_$property";
                $self->$set_property($_[0]);
                return $self;
            }
            if (!exists $self->{$property_key}) {
                $self->{$property_key} =
                    ref $isa eq 'CODE'
                    ? $isa->($self)
                    : $isa;
            }

            return $self->{$property_key};
        };
    }
    else {
        return sub {
            my $self = shift;

            if (@_) {
                require Carp;
                Carp::croak("You tried to set a value with $property(). Did "
                        ."you mean set_$property() ?");
            }

            if (!exists $self->{$property_key}) {
                $self->{$property_key} =
                    ref $isa eq 'CODE'
                    ? $isa->($self)
                    : $isa;
            }

            return $self->{$property_key};
        };
    }
}

sub _create_set_accessor {
    my ($caller_class, $property) = @_;
    my $options = $OPTIONS_FOR{$caller_class};
    my $property_key
        = $INTERNAL_ATTR_NOISE . $property .  $INTERNAL_ATTR_NOISE;

    if ($options->{'-chained'}) {

        return sub {
            my ($self, $value ) = @_;
            $self->{$property_key} = $value;
            return $self; # <-- this is the chained part.
        }
    }
    else {
        return sub  {
            my ($self, $value) = @_;
            $self->{$property_key} = $value;
            return;
        }
    }
}

1;

__END__