File Coverage

blib/lib/Rose/ObjectX/CAF/MethodMaker.pm

Criterion	Covered	Total	%
statement	28	40	70.0
branch	10	26	38.4
condition	5	14	35.7
subroutine	7	10	70.0
pod	1	1	100.0
total	51	91	56.0

package Rose::ObjectX::CAF::MethodMaker;
use warnings;
use strict;
use Carp;
use base qw( Rose::Object::MakeMethods::Generic );
my $Debug = 0;    #$ENV{PERL_DEBUG};

our $VERSION = '0.03';

=head1 NAME

Rose::ObjectX::CAF::MethodMaker - Class::Accessor::Fast compatability for Rose::Object

=head1 SYNOPSIS

 # see Rose::ObjectX::CAF

=head1 DESCRIPTION

This is a subclass of Rose::Object::MakeMethods::Generic. See those docs
and those of Rose::ObjectX::CAF.

=head1 METHODS

=head2 scalar

Overrides the Rose::Object::MakeMethods::Generic method of the same name
to provide read-only accessors like mk_ro_accessors().

=cut

# extend for mk_ro_accessors support
sub scalar {
    my ( $class, $name, $args ) = @_;

    my %methods;

    my $key       = $args->{'hash_key'}  || $name;
    my $interface = $args->{'interface'} || 'get_set';

    if ( $interface eq 'get_set_init' ) {
        my $init_method = $args->{'init_method'} || "init_$name";

        $methods{$name} = sub {
            return $_[0]->{$key} = $_[1] if ( @_ > 1 );

            return defined $_[0]->{$key}
                ? $_[0]->{$key}
                : ( $_[0]->{$key} = $_[0]->$init_method() );
        };
    }
    elsif ( $interface eq 'get_set' ) {
        if ( $Rose::Object::MakeMethods::Generic::Have_CXSA
            && !$ENV{'ROSE_OBJECT_NO_CLASS_XSACCESOR'} )
        {
            $methods{$name} = {
                make_method => sub {
                    my ( $name, $target_class, $options ) = @_;

                    $Debug
                        && warn
                        "Class::XSAccessor make method ($name => $key) in $target_class\n";

                    Class::XSAccessor->import(
                        accessors => { $name => $key },
                        class     => $target_class,
                        replace => $options->{'override_existing'} ? 1 : 0
                    );
                },
            };
        }
        else {
            $methods{$name} = sub {
                return $_[0]->{$key} = $_[1] if ( @_ > 1 );
                return $_[0]->{$key};
            };
        }
    }
    elsif ( $interface eq 'ro' ) {
        if ( $Rose::Object::MakeMethods::Generic::Have_CXSA
            && !$ENV{'ROSE_OBJECT_NO_CLASS_XSACCESOR'} )
        {
            $methods{$name} = {
                make_method => sub {
                    my ( $name, $target_class, $options ) = @_;

                    $Debug
                        && warn
                        "Class::XSAccessor make method ($name => $key) in $target_class\n";

                    Class::XSAccessor->import(
                        getters => { $name => $key },
                        class   => $target_class,
                        replace => $options->{'override_existing'} ? 1 : 0
                    );
                },
            };
        }
        else {
            $methods{$name} = sub {
                if ( @_ > 1 ) {
                    croak "usage: $name() is read-only (getter not setter)";
                }
                return $_[0]->{$key};
            };
        }
    }
    else { Carp::croak "Unknown interface: $interface" }

    return \%methods;
}

=head1 AUTHOR

Peter Karman, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Rose::ObjectX::CAF


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 ACKNOWLEDGEMENTS


=head1 COPYRIGHT & LICENSE

Copyright 2009 Peter Karman.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1;    # End of Rose::ObjectX::CAF