package Fey::Meta::HasOne; use strict; use warnings; use Fey::Exceptions qw( param_error ); use Moose; use MooseX::StrictConstructor; extends 'Fey::Meta::FK'; has associated_attribute => ( is => 'rw', isa => 'Maybe[Moose::Meta::Attribute]', init_arg => undef, lazy_build => 1, ); has associated_method => ( is => 'rw', isa => 'Maybe[Moose::Meta::Method]', init_arg => undef, lazy_build => 1, ); has allows_undef => ( is => 'ro', isa => 'Bool', lazy_build => 1, ); has handles => ( is => 'ro', # just gets passed on for attribute creation isa => 'Any', ); sub _build_associated_attribute { my $self = shift; return unless $self->is_cached(); # It'd be nice to set isa to the actual foreign class, but we may # not be able to map a table to a class yet, since that depends on # the related class being loaded. It doesn't really matter, since # this accessor is read-only, so there's really no typing issue to # deal with. my $type = 'Fey::Object::Table'; $type = "Maybe[$type]" if $self->allows_undef(); my %attr_p = ( is => 'rw', isa => $type, lazy => 1, default => $self->_make_subref(), writer => q{_set_} . $self->name(), predicate => q{_has_} . $self->name(), clearer => q{_clear_} . $self->name(), ); $attr_p{handles} = $self->handles() if $self->handles(); return $self->associated_class()->attribute_metaclass() ->new( $self->name(), %attr_p, ); } sub _build_is_cached { 1 } sub _build_associated_method { my $self = shift; return if $self->is_cached(); return $self->associated_class()->method_metaclass() ->wrap( name => $self->name(), package_name => $self->associated_class()->name(), body => $self->_make_subref(), ); } sub attach_to_class { my $self = shift; my $class = shift; $self->_set_associated_class($class); if ( $self->is_cached() ) { $class->add_attribute( $self->associated_attribute() ); } else { $class->add_method( $self->name() => $self->associated_method() ); } } sub detach_from_class { my $self = shift; return unless $self->associated_class(); if ( $self->is_cached() ) { $self->associated_class->remove_attribute( $self->name() ); } else { $self->associated_class->remove_method( $self->name() ); } $self->_clear_associated_class(); } no Moose; __PACKAGE__->meta()->make_immutable(); 1; __END__ =head1 NAME Fey::Meta::HasOne - A parent for has-one metaclasses =head1 DESCRIPTION This class exists to provide a common parent for the two has-one metaclasses, L<Fey::Meta::HasOne::ViaFK> and L<Fey::Meta::HasOne::ViaSelect>. =head1 CONSTRUCTOR OPTIONS This class accepts the following constructor options: =over 4 =item * handles This will simply be passed on when an attribute for this has-one relationship is created. Note that this is ignore if C<is_cached> is false. =item * allows_undef A boolean indicating whether or not the relationship's value can be C<undef>. =item * is_cached Defaults to true for this class. =back =head1 METHODS This provides the following methods: =head2 $ho->name() Corresponds to the value passed to the constructor. =head2 $ho->table() Corresponds to the value passed to the constructor. =head2 $ho->foreign_table() Corresponds to the value passed to the constructor. =head2 $ho->is_cached() Corresponds to the value passed to the constructor, or the calculated default. =head2 $ho->allows_undef() Corresponds to the value passed to the constructor. =head2 $ho->handles() Corresponds to the value passed to the constructor. =head2 $ho->attach_to_class($class) This method takes a F<Fey::Meta::Class::Table> object and attaches the relationship to the associated class. If this relationship is cached, it creates a new attribute, otherwise it creates a new method. The method/attribute returns an object belonging to the class associated with the foreign table. It can return C<undef> if C<allows_undef> is true. =head2 $ho->associated_class() The class associated with this object. This is undefined until C<< $ho->attach_to_class() >> is called. =head2 $ho->associated_attribute() Returns the attribute associated with this object, if any. =head2 $ho->associated_method() Returns the method associated with this object, if any. =head2 $ho->detach_from_class() If this object was attached to a class, it removes any attribute or method it made, and unsets the C<associated_class>. =head1 AUTHOR Dave Rolsky, <autarch@urth.org> =head1 BUGS See L<Fey::ORM> for details. =head1 COPYRIGHT & LICENSE Copyright 2006-2009 Dave Rolsky, All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut