Class::Meta::Constructor - Class::Meta class constructor introspection

  # Assuming MyApp::Thingy was generated by Class::Meta.
  my $class = MyApp::Thingy->my_class;

  print "\nConstructors:\n";
  for my $ctor ($class->constructors) {
      print "  o ", $ctor->name, $/;
      my $thingy = $ctor->call($class->package);
  }

  my $name = $ctor->name;

  my $package = $ctor->package;

  my $desc = $ctor->desc;

  my $desc = $ctor->label;

  my $view = $ctor->view;

  my $class = $ctor->class;

  my $obj = $ctor->call($package, @params);

  $ctor->build($class);

package Class::Meta::Constructor;

##############################################################################
# Dependencies                                                               #
##############################################################################
use strict;

##############################################################################
# Package Globals                                                            #
##############################################################################
our $VERSION = '0.65';

##############################################################################
# Constructors                                                               #
##############################################################################

sub new {
    my $pkg = shift;
    my $class = shift;

    # Check to make sure that only Class::Meta or a subclass is constructing a
    # Class::Meta::Constructor object.
    my $caller = caller;
    Class::Meta->handle_error("Package '$caller' cannot create $pkg "
                              . "objects")
      unless UNIVERSAL::isa($caller, 'Class::Meta')
        || UNIVERSAL::isa($caller, __PACKAGE__);

    # Make sure we can get all the arguments.
    $class->handle_error("Odd number of parameters in call to new() when "
                         . "named parameters were expected")
      if @_ % 2;
    my %p = @_;

    # Validate the name.
    $class->handle_error("Parameter 'name' is required in call to new()")
      unless $p{name};
    $class->handle_error("Constructor '$p{name}' is not a valid constructor "
                         . "name -- only alphanumeric and '_' characters "
                         . "allowed")
      if $p{name} =~ /\W/;

    # Make sure the name hasn't already been used for another constructor or
    # method.
    $class->handle_error("Method '$p{name}' already exists in class "
                         . "'$class->{package}'")
      if exists $class->{ctors}{$p{name}}
      or exists $class->{meths}{$p{name}};

    # Check the visibility.
    if (exists $p{view}) {
        $p{view} = Class::Meta::_str_to_const($p{view});
        $class->handle_error("Not a valid view parameter: '$p{view}'")
          unless $p{view} == Class::Meta::PUBLIC
          ||     $p{view} == Class::Meta::PROTECTED
          ||     $p{view} == Class::Meta::TRUSTED
          ||     $p{view} == Class::Meta::PRIVATE;
    } else {
        # Make it public by default.
        $p{view} = Class::Meta::PUBLIC;
    }

    # Use passed code or create the constructor?
    if ($p{code}) {
        my $ref = ref $p{code};
        $class->handle_error(
            'Parameter code must be a code reference'
        ) unless $ref && $ref eq 'CODE';
        $p{create} = 0;
    } else {
        $p{create} = 1 unless exists $p{create};
    }

    # Validate or create the method caller if necessary.
    if ($p{caller}) {
        my $ref = ref $p{caller};
        $class->handle_error("Parameter caller must be a code reference")
          unless $ref && $ref eq 'CODE';
    } else {
        $p{caller} = UNIVERSAL::can($class->{package}, $p{name})
          unless $p{create};
    }

    # Create and cache the constructor object.
    $p{package} = $class->{package};
    $class->{ctors}{$p{name}} = bless \%p, ref $pkg || $pkg;

    # Index its view.
    push @{ $class->{all_ctor_ord} }, $p{name};
    if ($p{view} > Class::Meta::PRIVATE) {
        push @{$class->{prot_ctor_ord}}, $p{name}
          unless $p{view} == Class::Meta::TRUSTED;
        if ($p{view} > Class::Meta::PROTECTED) {
            push @{$class->{trst_ctor_ord}}, $p{name};
            push @{$class->{ctor_ord}}, $p{name}
              if $p{view} == Class::Meta::PUBLIC;
        }
    }

    # Store a reference to the class object.
    $p{class} = $class;

    # Let 'em have it.
    return $class->{ctors}{$p{name}};
}


##############################################################################
# Instance Methods                                                           #
##############################################################################

sub name    { $_[0]->{name}    }
sub package { $_[0]->{package} }
sub desc    { $_[0]->{desc}    }
sub label   { $_[0]->{label}   }
sub view    { $_[0]->{view}    }
sub class   { $_[0]->{class}   }

sub call {
    my $self = shift;
    my $code = $self->{caller} or $self->class->handle_error(
        q{Cannot call constructor '}, $self->name, q{'}
    );
    goto &$code;
}

##############################################################################

sub build {
    my ($self, $specs) = @_;

    # Check to make sure that only Class::Meta or a subclass is building
    # constructors.
    my $caller = caller;
    $self->class->handle_error("Package '$caller' cannot call " . ref($self)
                               . "->build")
      unless UNIVERSAL::isa($caller, 'Class::Meta')
        || UNIVERSAL::isa($caller, __PACKAGE__);

    # Just bail if we're not creating or installing the constructor.
    return $self unless delete $self->{create} || $self->{code};

    # Build a construtor that takes a parameter list and assigns the
    # the values to the appropriate attributes.
    my $name = $self->name;

    my $sub = delete $self->{code} || sub {
        my $package = ref $_[0] ? ref shift : shift;
        my $class = $specs->{$package};

        # Throw an exception for attempts to create items of an abstract
        # class.
        $class->handle_error(
            "Cannot construct objects of astract class $package"
        ) if $class->abstract;

        # Is there a sub passed as the last argument?
        my $sub = @_ % 2 && ref $_[-1] eq 'CODE' ? pop @_ : undef;

        # Just grab the parameters and let an error be thrown by Perl
        # if there aren't the right number of them.
        my %p = @_;
        my $new = bless {} => $package;

        # Assign all of the attribute values.
        my @req;
        if (my $attrs = $class->{attrs}) {
            foreach my $attr (@{ $attrs }{ @{ $class->{all_attr_ord} } }) {
                # Skip class attributes.
                next if $attr->context == Class::Meta::CLASS;
                my $key = $attr->name;
                if (exists $p{$key} && $attr->authz >= Class::Meta::SET) {
                    # Let them set the value.
                    $attr->set($new, delete $p{$key});
                } elsif (!exists $new->{$key}) {
                    # Use the default value.
                    $new->{$key} = $attr->default;
                    push @req, $attr if $attr->required;
                }
            }
        }

        # Check for params for which attributes are private or don't exist.
        if (my @attributes = keys %p) {
            # Attempts to assign to non-existent attributes fail.
            my $c = $#attributes > 0 ? 'attributes' : 'attribute';
            local $" = q{', '};
            $class->handle_error(
                "No such $c '@attributes' in $self->{package} objects"
            );
        }

        # Run the block passed, if there is one.
        $sub->($new) if $sub;

        # Enforce required attributes.
        if (@req and my @miss = grep { !defined $new->{ $_->name } } @req ) {
            my $c = $#miss > 0 ? 'Attributes' : 'Attribute';
            my $a = join q{', '}, map { $_->name } @miss;
            $class->handle_error(
                "$c '$a' must be defined in $self->{package} objects"
            );
        }

        return $new;
    };

    # Add protected, private, or trusted checks, if required.
    if ($self->view == Class::Meta::PROTECTED) {
        my $real_sub = $sub;
        my $pkg      = $self->package;
        my $class    = $self->class;
        $sub = sub {
             $class->handle_error("$name is a protected constrctor of $pkg")
                 unless caller->isa($pkg);
             goto &$real_sub;
        };
    } elsif ($self->view == Class::Meta::PRIVATE) {
        my $real_sub = $sub;
        my $pkg      = $self->package;
        my $class    = $self->class;
        $sub = sub {
            $class->handle_error("$name is a private constructor of $pkg")
                unless caller eq $pkg;
             goto &$real_sub;
         };
    }

    # Install the constructor.
    $self->{caller} ||= $sub;
    no strict 'refs';
    *{"$self->{package}::$name"} = $sub;
}

1;
__END__