view release on metacpan or  search on metacpan

lib/Badger/Class/Methods.pm  view on Meta::CPAN

    my ($class, $target, $methods) = shift->args(@_);
    my $index = 0;

    foreach my $method (@$methods) {
        my $i = $index++;           # new lexical var for closure
        $target->import_symbol(
            $method => sub {
                return @_ > 1
                    ? ($_[0]->[$i] = $_[1])
                    :  $_[0]->[$i];
            }
        );
    }
}

sub auto_can {
    my ($class, $target, $methods) = shift->args(@_);

    die "auto_can only support a single method at this time\n"
        if @$methods != 1;
        
    my $method = shift @$methods;

    croak "Invalid auto_can method specified: $method\n"
        if ref $method eq CODE;
        
    # avoid runaways
    my $seen = { };
    
    $class->debug("installing AUTOLOAD and can() in $target") if DEBUG;

    $target->import_symbol( 
        can => sub {
            my ($this, $name, @args) = @_;
            $class->debug("looking to see if $this can $name()") if DEBUG;

            # This avoids runaways where can() calls itself repeatedly, but 
            # doesn't prevent can() from being called several times for the
            # same item. 
            return if $seen->{ $name };
            local $seen->{ $name } = 1;

            return $this->SUPER::can($name)
                || $this->$method($name, @args);
        }
    );

    $target->import_symbol( 
        AUTOLOAD => sub {
            my ($this, @args) = @_;
            my ($name) = ($AUTOLOAD =~ /([^:]+)$/ );
            return if $name eq 'DESTROY';
            if (my $method = $this->can($name, @args)) {
                my $that = class($this);
                $class->debug("$class installing $name method in $that") if DEBUG;
                $that->method( $name => $method );
                return $method->($this, @args);
            }

            # Hmmm... what if $this isn't a subclass of Badger::Base?
            return $this->error_msg( bad_method => $name, ref $this, (caller())[1,2] );
        }
    );

    $class->debug("installed AUTOLOAD and can() in $target") if DEBUG;
}

sub args {
    my $class   = shift;
    my $target  = shift;
    my $methods = @_ == 1 ? shift : [ @_ ];

    # update $target to a Badger::Class object if not already one
    $target  = class($target)
        unless is_object(BCLASS, $target);

    # split text string into list ref of method names
    $methods = [ split(DELIMITER, $methods) ] 
        unless ref $methods eq ARRAY;
    
    return ($class, $target, $methods);
}
        


1;

__END__

=head1 NAME

Badger::Class::Method - metaprogramming module for adding methods to a class

=head1 SYNOPSIS

    package My::Module;
    
    # using the module directly
    use Badger::Class::Methods
        accessors => 'foo bar',
        mutators  => 'wiz bang';
    
    # or via Badger::Class
    use Badger::Class
        accessors => 'foo bar',
        mutators  => 'wiz bang';

=head1 DESCRIPTION

This module can be used to generate methods for a class. It can be used
directly, or via the L<accessors|Badger::Class/accessors>, 
L<accessors|Badger::Class/accessors> and L<slots|Badger::Class/slots>
export hooks in L<Badger::Class>.

=head1 METHODS

=head2 generate($class,$type,$methods)

This method is a central dispatcher to other methods.

    Badger::Class::Methods->generate(