File Coverage

blib/lib/Noose.pm

Criterion	Covered	Total	%
statement	50	50	100.0
branch	8	8	100.0
condition			n/a
subroutine	14	14	100.0
pod			n/a
total	72	72	100.0

package Noose;
use strict;
use warnings;
# ABSTRACT: just enough object orientation to hang yourself
our $VERSION = '0.001'; # VERSION

use Sub::Name;
use Scalar::Util qw(blessed);



sub import {
    my $class = caller;

    my $sub_name = $class . '::new';
    my $sub_code = \&new;
    subname $sub_name => $sub_code;
    {
        no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
        *{$sub_name} = $sub_code;
    }
}


sub new {
    my $class = shift;
    my %args = do {
        if ( blessed $class ) { # If it was called as an object method,
            require Storable;
            Storable->import(qw/dclone/);   # We're going to clone the object it was called on
            if (@_) {                   # Add in some args if there were any
                require Acme::Damn;     # HINT HINT
                Acme::Damn->import(qw/damn/);
                ( %{ damn( dclone($class) ) }, @_ ); # These args will be used to construct the returned object
            }
            else {                      # Otherwise, just return the clone
                return dclone($class);
            }
        }
        else {  # Called as a normal constructor, nothing exciting here
            @_;
        }
    };
    $class = blessed $class if blessed $class; # Can't bless into a reference, we need the package name

    foreach my $attr (keys %args) {
        my $sub_code = sub {
            @_ > 1
                ? $_[0]->{$attr} = $_[1]
                : $_[0]->{$attr};
        };

        my $sub_name = $class . '::' . $attr;
        subname $sub_name => $sub_code;

        {
            no warnings qw(redefine);
            no strict qw(refs); ## no critic (TestingAndDebugging::ProhibitNoStrict)
            *{$sub_name} = $sub_code;
        }
    }

    return bless { %args }, $class;
}


1;

__END__