[gitmo/Class-MOP.git] / lib / Class / MOP / Method.pm


package Class::MOP::Method;

use strict;
use warnings;

use Carp         'confess';
use Scalar::Util 'weaken';

our $VERSION   = '0.64_01';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';

use base 'Class::MOP::Object';

# NOTE:
# if poked in the right way,
# they should act like CODE refs.
use overload '&{}' => sub { $_[0]->body }, fallback => 1;

our $UPGRADE_ERROR_TEXT = q{
---------------------------------------------------------
NOTE: this error is likely not an error, but a regression
caused by the latest upgrade to Moose/Class::MOP. Consider
upgrading any MooseX::* modules to their latest versions
before spending too much time chasing this one down.
---------------------------------------------------------
};

# construction

sub wrap {
    my ( $class, @args ) = @_;

    unshift @args, 'body' if @args % 2 == 1;

    my %params = @args;
    my $code = $params{body};

    ('CODE' eq ref($code))
        || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";

    ($params{package_name} && $params{name})
        || confess "You must supply the package_name and name parameters $UPGRADE_ERROR_TEXT";

    my $self = (ref($class) || $class)->_new(\%params);

    weaken($self->{associated_metaclass}) if $self->{associated_metaclass};

    return $self;
}

sub _new {
    my $class = shift;
    my $params = @_ == 1 ? $_[0] : {@_};

    my $self = bless {
        'body'                 => $params->{body},
        'associated_metaclass' => $params->{associated_metaclass},
        'package_name'         => $params->{package_name},
        'name'                 => $params->{name},
    } => $class;
}

## accessors

sub body { (shift)->{'body'} }

sub associated_metaclass { shift->{'associated_metaclass'} }

sub attach_to_class {
    my ( $self, $class ) = @_;
    $self->{associated_metaclass} = $class;
    weaken($self->{associated_metaclass});
}

sub detach_from_class {
    my $self = shift;
    delete $self->{associated_metaclass};
}

sub package_name {
    my $self = shift;
    $self->{'package_name'} ||= (Class::MOP::get_code_info($self->body))[0];
}

sub name {
    my $self = shift;
    $self->{'name'} ||= (Class::MOP::get_code_info($self->body))[1];
}

sub fully_qualified_name {
    my $code = shift;
    $code->package_name . '::' . $code->name;
}

# NOTE:
# the Class::MOP bootstrap
# will create this for us
# - SL
# sub clone { ... }

1;

__END__

=pod

=head1 NAME

Class::MOP::Method - Method Meta Object

=head1 DESCRIPTION

The Method Protocol is very small, since methods in Perl 5 are just
subroutines within the particular package. We provide a very basic
introspection interface.

=head1 METHODS

=head2 Introspection

=over 4

=item B<meta>

This will return a B<Class::MOP::Class> instance which is related
to this class.

=back

=head2 Construction

=over 4

=item B<wrap ($code, %params)>

This is the basic constructor, it returns a B<Class::MOP::Method>
instance which wraps the given C<$code> reference. You can also
set the C<package_name> and C<name> attributes using the C<%params>.
If these are not set, then thier accessors will attempt to figure
it out using the C<Class::MOP::get_code_info> function.

=item B<clone (%params)>

This will make a copy of the object, allowing you to override
any values by stuffing them in C<%params>.

=back

=head2 Informational

=over 4

=item B<body>

This returns the actual CODE reference of the particular instance.

=item B<name>

This returns the name of the CODE reference.

=item B<associated_metaclass>

The metaclass of the method

=item B<package_name>

This returns the package name that the CODE reference is attached to.

=item B<fully_qualified_name>

This returns the fully qualified name of the CODE reference.

=back

=head2 Metaclass

=over 4

=item B<attach_to_class>

Sets the associated metaclass

=item B<detach_from_class>

Disassociates the method from the metaclass

=back

=head1 AUTHORS

Stevan Little E<lt>stevan@iinteractive.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006-2008 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

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

=cut
Commit	Line	Data
8b978dd5	1
	2	package Class::MOP::Method;
	3
	4	use strict;
	5	use warnings;
	6
2eb717d5	7	use Carp 'confess';
5e607260	8	use Scalar::Util 'weaken';
2eb717d5	9
d519662a	10	our $VERSION = '0.64_01';
d519662a	11	$VERSION = eval $VERSION;
f0480c45	12	our $AUTHORITY = 'cpan:STEVAN';
de19f115	13
b1897d4d	14	use base 'Class::MOP::Object';
b1897d4d	15
ce2ae40f	16	# NOTE:
32202ce2	17	# if poked in the right way,
ce2ae40f	18	# they should act like CODE refs.
c23184fc	19	use overload '&{}' => sub { $_[0]->body }, fallback => 1;
7855ddba	20
32202ce2	21	our $UPGRADE_ERROR_TEXT = q{
	22	---------------------------------------------------------
	23	NOTE: this error is likely not an error, but a regression
	24	caused by the latest upgrade to Moose/Class::MOP. Consider
	25	upgrading any MooseX::* modules to their latest versions
	26	before spending too much time chasing this one down.
	27	---------------------------------------------------------
	28	};
	29
de19f115	30	# construction
de19f115	31
32202ce2	32	sub wrap {
5caf45ce	33	my ( $class, @args ) = @_;
	34
	35	unshift @args, 'body' if @args % 2 == 1;
	36
	37	my %params = @args;
	38	my $code = $params{body};
32202ce2	39
9b522fc4	40	('CODE' eq ref($code))
4d47b77f	41	\|\| confess "You must supply a CODE reference to bless, not (" . ($code \|\| 'undef') . ")";
32202ce2	42
b38f3848	43	($params{package_name} && $params{name})
32202ce2	44	\|\| confess "You must supply the package_name and name parameters $UPGRADE_ERROR_TEXT";
32202ce2	45
0bfc85b8	46	my $self = (ref($class) \|\| $class)->_new(\%params);
5e607260	47
	48	weaken($self->{associated_metaclass}) if $self->{associated_metaclass};
	49
	50	return $self;
de19f115	51	}
de19f115	52
71b98d4f	53	sub _new {
0bfc85b8	54	my $class = shift;
0bfc85b8	55	my $params = @_ == 1 ? $_[0] : {@_};
71b98d4f	56
71b98d4f	57	my $self = bless {
0bfc85b8	58	'body' => $params->{body},
	59	'associated_metaclass' => $params->{associated_metaclass},
	60	'package_name' => $params->{package_name},
	61	'name' => $params->{name},
71b98d4f	62	} => $class;
	63	}
	64
ce2ae40f	65	## accessors
ce2ae40f	66
8683db0e	67	sub body { (shift)->{'body'} }
7855ddba	68
5e607260	69	sub associated_metaclass { shift->{'associated_metaclass'} }
b1897d4d	70
5e607260	71	sub attach_to_class {
	72	my ( $self, $class ) = @_;
	73	$self->{associated_metaclass} = $class;
	74	weaken($self->{associated_metaclass});
	75	}
	76
	77	sub detach_from_class {
	78	my $self = shift;
	79	delete $self->{associated_metaclass};
	80	}
de19f115	81
32202ce2	82	sub package_name {
4c105333	83	my $self = shift;
8683db0e	84	$self->{'package_name'} \|\|= (Class::MOP::get_code_info($self->body))[0];
de19f115	85	}
de19f115	86
32202ce2	87	sub name {
4c105333	88	my $self = shift;
8683db0e	89	$self->{'name'} \|\|= (Class::MOP::get_code_info($self->body))[1];
2eb717d5	90	}
de19f115	91
96ceced8	92	sub fully_qualified_name {
4c105333	93	my $code = shift;
4c105333	94	$code->package_name . '::' . $code->name;
96ceced8	95	}
96ceced8	96
4c105333	97	# NOTE:
	98	# the Class::MOP bootstrap
	99	# will create this for us
	100	# - SL
	101	# sub clone { ... }
	102
8b978dd5	103	1;
	104
	105	__END__
	106
	107	=pod
	108
32202ce2	109	=head1 NAME
8b978dd5	110
	111	Class::MOP::Method - Method Meta Object
	112
8b978dd5	113	=head1 DESCRIPTION
8b978dd5	114
32202ce2	115	The Method Protocol is very small, since methods in Perl 5 are just
32202ce2	116	subroutines within the particular package. We provide a very basic
86482605	117	introspection interface.
fe122940	118
2eb717d5	119	=head1 METHODS
2eb717d5	120
de19f115	121	=head2 Introspection
2eb717d5	122
de19f115	123	=over 4
fe122940	124
2eb717d5	125	=item B<meta>
2eb717d5	126
32202ce2	127	This will return a B<Class::MOP::Class> instance which is related
fe122940	128	to this class.
fe122940	129
2eb717d5	130	=back
2eb717d5	131
de19f115	132	=head2 Construction
	133
	134	=over 4
	135
4c105333	136	=item B<wrap ($code, %params)>
127d39a7	137
32202ce2	138	This is the basic constructor, it returns a B<Class::MOP::Method>
32202ce2	139	instance which wraps the given C<$code> reference. You can also
4c105333	140	set the C<package_name> and C<name> attributes using the C<%params>.
32202ce2	141	If these are not set, then thier accessors will attempt to figure
4c105333	142	it out using the C<Class::MOP::get_code_info> function.
	143
	144	=item B<clone (%params)>
	145
32202ce2	146	This will make a copy of the object, allowing you to override
4c105333	147	any values by stuffing them in C<%params>.
de19f115	148
de19f115	149	=back
	150
	151	=head2 Informational
	152
	153	=over 4
	154
7855ddba	155	=item B<body>
7855ddba	156
127d39a7	157	This returns the actual CODE reference of the particular instance.
127d39a7	158
de19f115	159	=item B<name>
de19f115	160
127d39a7	161	This returns the name of the CODE reference.
127d39a7	162
5e607260	163	=item B<associated_metaclass>
	164
	165	The metaclass of the method
	166
de19f115	167	=item B<package_name>
de19f115	168
127d39a7	169	This returns the package name that the CODE reference is attached to.
127d39a7	170
96ceced8	171	=item B<fully_qualified_name>
96ceced8	172
127d39a7	173	This returns the fully qualified name of the CODE reference.
127d39a7	174
96ceced8	175	=back
96ceced8	176
5e607260	177	=head2 Metaclass
	178
	179	=over 4
	180
	181	=item B<attach_to_class>
	182
	183	Sets the associated metaclass
	184
	185	=item B<detach_from_class>
	186
	187	Disassociates the method from the metaclass
	188
	189	=back
	190
1a09d9cc	191	=head1 AUTHORS
8b978dd5	192
a2e85e6c	193	Stevan Little E<lt>stevan@iinteractive.comE<gt>
8b978dd5	194
	195	=head1 COPYRIGHT AND LICENSE
	196
69e3ab0a	197	Copyright 2006-2008 by Infinity Interactive, Inc.
8b978dd5	198
	199	L<http://www.iinteractive.com>
	200
	201	This library is free software; you can redistribute it and/or modify
32202ce2	202	it under the same terms as Perl itself.
8b978dd5	203
16e960bd	204	=cut
16e960bd	205