File Coverage

blib/lib/Class/Accessor/Constructor.pm

Criterion	Covered	Total	%
statement	90	96	93.7
branch	24	32	75.0
condition	10	19	52.6
subroutine	18	18	100.0
pod	3	3	100.0
total	145	168	86.3

use 5.008;
use strict;
use warnings;

package Class::Accessor::Constructor;
BEGIN {
  $Class::Accessor::Constructor::VERSION = '1.111590';
}

# ABSTRACT: Constructor generator
use Carp 'cluck';
use parent qw(
  Class::Accessor
  Class::Accessor::Installer
  Data::Inherited
);
use constant NO_DIRTY   => 0;
use constant WITH_DIRTY => 1;

sub mk_singleton_constructor {
    my ($self, @args) = @_;
    my $class = ref $self || $self;
    @args = ('new') unless @args;
    my $singleton;
    for my $name (@args) {
        my $instance_method = "${name}_instance";
        $self->install_accessor(
            name => $name,
            code => sub {
                local $DB::sub = local *__ANON__ = "${class}::${name}"
                  if defined &DB::DB && !$Devel::DProf::VERSION;
                my $self = shift;
                $singleton ||= $self->$instance_method(@_);
            },
        );
        $self->document_accessor(
            name    => $name,
            purpose => <<'EODOC',
Creates and returns a new object. The object will be a singleton, so repeated
calls to the constructor will always return the same object. The constructor
will accept as arguments a list of pairs, from component name to initial
value. For each pair, the named component is initialized by calling the
method of the same name with the given value. If called with a single hash
reference, it is dereferenced and its key/value pairs are set as described
before.
EODOC
            examples => [
                "my \$obj = $class->$name;",
                "my \$obj = $class->$name(\%args);",
            ],
        );
        $class->mk_constructor($instance_method);
    }
    $self;    # for chaining
}

sub mk_constructor {
    my $self = shift;
    $self->_make_constructor(NO_DIRTY, @_);
    $self;    # for chaining
}

sub mk_constructor_with_dirty {
    my $self = shift;
    $self->_make_constructor(WITH_DIRTY, @_);
    $self;    # for chaining
}

sub _make_constructor {
    my ($self, $should_dirty, @args) = @_;
    my $target_class = ref $self || $self;
    @args = ('new') unless @args;

    # We generate a method into package $class which uses methods it needs to
    # inherit from Class::Accessor::Constructor::Base (which in turn inherits
    # from Data::Inherited), so we need to make sure that $class actually
    # inherits from Class::Accessor::Constructor::Base.
    unless (UNIVERSAL::isa($target_class, 'Class::Accessor::Constructor::Base'))
    {
        require Class::Accessor::Constructor::Base;
        no strict 'refs';
        push @{"${target_class}::ISA"}, 'Class::Accessor::Constructor::Base';
    }
    for my $name (@args) {

        # n00bs getting pwned here
        $self->install_accessor(
            name => $name,
            code => sub {
                local $DB::sub = local *__ANON__ = "${target_class}::${name}"
                  if defined &DB::DB;
                my $class = shift;
                my $self;

                # If we're given a reference, don't tie() it. Only tie()
                # completely new objects.
                if (ref $class) {
                    $self = $class;
                } else {
                    my %self = ();
                    tie %self, 'Class::Accessor::Constructor::Base'
                      if $should_dirty;
                    $self = bless \%self, $class;
                    if ($should_dirty) {

                      # set the results of every_list() from here, because
                      # a tied class' STORE() method is given a $self with a ref
                      # of the tied class, not the original class.
                        $self->hygienic(scalar $self->every_list('HYGIENIC'));
                        $self->unhygienic(
                            scalar $self->every_list('UNHYGIENIC'));

                        # Reset dirty flag because setting the above will cause
                        # the dirty flag to be set.
                        $self->clear_dirty;
                    }
                }
                our %cache;
                my %args;

               # The following should be equivalent to
               #
               # my $munger = $cache{MUNGE_CONSTRUCTOR_ARGS}{ref $self} //=
               #     $self->can('MUNGE_CONSTRUCTOR_ARGS');
               #
               # but we want this to run under perl 5.8.8 as well. Can't use ||=
               # with can() because if the object "can't", then can will return
               # undef so it will check again the next time.
                my $munger;
                unless (exists $cache{MUNGE_CONSTRUCTOR_ARGS}{ ref $self }) {
                    $cache{MUNGE_CONSTRUCTOR_ARGS}{ ref $self } =
                      $self->can('MUNGE_CONSTRUCTOR_ARGS');
                }
                $munger = $cache{MUNGE_CONSTRUCTOR_ARGS}{ ref $self };
                if ($munger) {
                    %args = $munger->($self, @_);
                } else {
                    %args =
                      (scalar(@_ == 1) && ref($_[0]) eq 'HASH')
                      ? %{ $_[0] }
                      : @_;
                }

                # Note: DEFAULTS are cached, so they have to be static.
                my $defaults = $cache{DEFAULTS}{ ref $self } ||=
                  [ $self->every_hash('DEFAULTS') ];
                %args = (@$defaults, %args);

              # If a class wants to order some args first, it can define a
              # FIRST_CONSTRUCTOR_ARGS list (will be cumulative over inheritance
              # tree due to NEXT.pm magic)
              # my @first = $self->every_list('FIRST_CONSTRUCTOR_ARGS');
                my $first = $cache{FIRST_CONSTRUCTOR_ARGS}{ ref $self } ||=
                  [ $self->every_list('FIRST_CONSTRUCTOR_ARGS') ];
                my %seen;
                for (@$first, keys %args) {
                    next if $seen{$_}++;
                    my $setter;
                    unless (exists $cache{setter}{$_}{ ref $self }) {
                        $cache{setter}{$_}{ ref $self } = $self->can($_);
                    }
                    $setter = $cache{setter}{$_}{ ref $self };
                    unless ($setter) {
                        my $error = sprintf "%s: no setter method for [%s]\n",
                          ref($self), $_;
                        cluck $error;
                        die $error;
                    }
                    $setter->($self, $args{$_});
                }
                my $init;
                unless (exists $cache{INIT}{ ref $self }) {
                    $cache{INIT}{ ref $self } = $self->can('init');
                }
                $init = $cache{INIT}{ ref $self };
                $self->init(%args) if $init;
                $self;
            },
        );
        $self->document_accessor(
            name    => $name,
            purpose => <<'EODOC',
Creates and returns a new object. The constructor will accept as arguments a
list of pairs, from component name to initial value. For each pair, the named
component is initialized by calling the method of the same name with the given
value. If called with a single hash reference, it is dereferenced and its
key/value pairs are set as described before.
EODOC
            examples => [
                "my \$obj = $target_class->$name;",
                "my \$obj = $target_class->$name(\%args);",
            ]
        );
    }
}
1;


__END__