package Class::Meta::Constructor;

# $Id: Constructor.pm,v 1.44 2004/04/20 12:59:12 david Exp $

=head1 NAME

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

=head1 SYNOPSIS

  # 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;
  }

=head1 DESCRIPTION

This class provides an interface to the C<Class::Meta> objects that describe
class constructors. It supports a simple description of the constructor, a
label, and the constructor visibility (private, protected, or public).

Class::Meta::Constructor objects are created by Class::Meta; they are never
instantiated directly in client code. To access the constructor objects for a
Class::Meta-generated class, simply call its C<class> method to retrieve its
Class::Meta::Class object, and then call the C<constructors()> method on the
Class::Meta::Class object.

=cut

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

##############################################################################
# Package Globals                                                            #
##############################################################################
our $VERSION = "0.31";

##############################################################################
# Constructors                                                               #
##############################################################################
# We don't document new(), since it's a protected method, really. Its
# parameters are documented in Class::Meta.

sub new {
    my $pkg = shift;
    my $spec = 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 ". __PACKAGE__
                              . " objects")
      unless UNIVERSAL::isa($caller, 'Class::Meta');

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

    # Validate the name.
    $spec->{class}->handle_error("Parameter 'name' is required in call to "
                                 . "new()") unless $p{name};
    $spec->{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.
    $spec->{class}->handle_error("Method '$p{name}' already exists in class "
                                 . "'$spec->{package}'")
      if exists $spec->{ctors}{$p{name}}
      or exists $spec->{meths}{$p{name}};

    # Check the visibility.
    if (exists $p{view}) {
        $spec->{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::PRIVATE;
    } else {
        # Make it public by default.
        $p{view} = Class::Meta::PUBLIC;
    }

    # Check the creation constant.
    $p{create} = 1 unless defined $p{create};

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

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

    # Index its view.
    if ($p{view} > Class::Meta::PRIVATE) {
        push @{$spec->{prot_ctor_ord}}, $p{name};
        push @{$spec->{ctor_ord}}, $p{name}
          if $p{view} == Class::Meta::PUBLIC;
    }

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

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


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

=head1 INTERFACE

=head2 Instance Methods

=head3 name

  my $name = $ctor->name;

Returns the constructor name.

=head3 package

  my $package = $ctor->package;

Returns the package name of the class that constructor is associated with.

=head3 desc

  my $desc = $ctor->desc;

Returns the description of the constructor.

=head3 label

  my $desc = $ctor->label;

Returns label for the constructor.

=head3 view

  my $view = $ctor->view;

Returns the view of the constructor, reflecting its visibility. The possible
values are defined by the following constants:

=over 4

=item Class::Meta::PUBLIC

=item Class::Meta::PRIVATE

=item Class::Meta::PROTECTED

=back

=head3 class

  my $class = $attr->class;

Returns the Class::Meta::Class object that this constructor is associated
with. Note that this object will always represent the class in which the
constructor is defined, and I<not> any of its subclasses.

=cut

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

=head3 call

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

Executes the constructor for the class, passing the parameters to it. Note
that it uses a C<goto> to execute the constructor, so the call to C<call()>
itself will not appear in a call stack trace.

=cut

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

##############################################################################
# Private Methods
##############################################################################

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 " . __PACKAGE__
                               . "->build")
      unless UNIVERSAL::isa($caller, 'Class::Meta');

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

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

    my $sub = sub {
        my $class = ref $_[0] ? ref shift : shift;
        my $spec = $specs->{$class};

        # 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 {}, ref $class || $class;

        # Assign all of the attribute values.
        if ($spec->{attrs}) {
            foreach my $attr (values %{ $spec->{attrs} }) {
                # 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});
                } else {
                    # Use the default value.
                    $new->{$key} = $attr->default;
                }
            }
        }

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

    # Add public and private checks, if required.
    if ($self->view == Class::Meta::PROTECTED) {
        my $real_sub = $sub;
        my $pkg = $self->package;
         $sub = sub {
             $self->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;
        $sub = sub {
            $self->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__

=head1 DISTRIBUTION INFORMATION

This file was packaged with the Class-Meta-0.31 distribution.

=head1 BUGS

Please report all bugs via the CPAN Request Tracker at
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.

=head1 AUTHOR

David Wheeler <david@kineticode.com>

=head1 SEE ALSO

Other classes of interest within the Class::Meta distribution include:

=over 4

=item L<Class::Meta|Class::Meta>

=item L<Class::Meta::Class|Class::Meta::Class>

=item L<Class::Meta::Method|Class::Meta::Method>

=item L<Class::Meta::Attribute|Class::Meta::Attribute>

=back

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2002-2004, David Wheeler. All Rights Reserved.

This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut
