Class::Role - Support for the role object model

Class-Role documentation Contained in the Class-Role distribution.

Index

Code Index:

NAME

Top

Class::Role - Support for the role object model

SYNOPSIS

Top

    package LongLiver;
        use Class::Role;              # This is a role

        sub profess {
            my ($self) = @_;
            print $self->name . " live a long time\n";
        }

    package Donkey;
        use Class::Role LongLiver;    # Incorporates this role

        sub name {
            return "Donkeys";
        }

        sub new {
            bless {} => shift;
        }

    package main;
    my $benjamin = Donkey->new;

    $benjamin->profess;         # prints "Donkeys live a long time"

DESCRIPTION

Top

Class::Role is an implementation of 'traits', as explained in this paper:

    http://www.cse.ogi.edu/~black/publications/TR_CSE_02-012.pdf

It's an object model similar to mixins, except saner. The module gets its name from Larry's current name for a similar concept in Perl 6's object model. In Perl 6, traits are a different thing entirely, and I don't want to confuse anybody. :-)

Inheritance is [was designed to be] used as a way to extend an object in its behavior, but it is often abused as a method of simple code reuse (in the form of stateless, abstract classes). Roles fit this latter, er, role better. A Role is a small, combinable piece of reusable code.

Roles are stateless collections of methods that can be combined into a class (or another role). These methods may call methods of the combining object, not defined by the role itself. They are incorporated in as if they were written directly into the combining class.

To define a role, create a package with the methods you want the role to provide, and use Class::Role, as in the SYNOPSIS.

When creating a role, you may specify which methods you wish to export to the combining class with the -methods option. If the option is not given, all methods (except for import) are exported.

To combine a role, either use Class::Role with the name of the role as an argument, or just eg. use TwoLegs, if you have defined it in TwoLegs.pm. Methods defined in the combining class override methods in a combined role, however methods in the role override methods in any base classes.

When combining a role, there are several options you can give:

-excludes

Give a method or arrayref of methods to exclude from combining. This is the recommended way to deal with conflicts (see below).

For instance,

    use Class::Role Farm, excludes => ['snowball'];
-conflict

What to do if there's role conflict. One of the values:

'die'

Exit with an error message. This is the default.

'exclude'

Omit the offending method entirely. Usually this means you'll implement it yourself.

'keep'

"Keep" any existing role method defined; that is, use the first one. Methods in the combining class still override.

'replace'

Overwrite any existing role method defined; that is, use the last one. Methods in the combining class still override.

'mixin'

Synonym for 'replace'.

It is recommended that you keep this the default.

There is one small detail regarding methods behaving exactly as if they were written directly into the combining class: SUPER doesn't work right. SUPER would instead look in any base classes of the role, not of the the combining class.

To circumvent this, Class::Role provides the pseudopackage PARENT, which works exactly like SUPER, except that it works correctly for (and only for) roles. So, when you're writing a role, use PARENT instead of SUPER.

SEE ALSO

Top

mixin, Class::Mixin

AUTHOR

Top

Luke Palmer, <luke@luqui.org>

COPYRIGHT AND LICENSE

Top

Copyright 2003 by Luke Palmer

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

Class-Role documentation Contained in the Class-Role distribution. 
package Class::Role;

use 5.006;
use Carp;

our $VERSION = 0.03;

my %valid_option_keys = (
    -excludes => 1,
    -conflict => 1,
);
my %valid_param_keys = (
    -methods => 1,
);

sub import {
    shift;  # Package name
    
    if ($_[0] && $_[0] !~ /^-/) {   # If you don't want a seperate 
                                    # file for each role
        goto &{"$_[0]::import"};
    }
    
    my %param = @_;

    for (keys %param) {
        croak "Unknown option ($_) for Class::Role" unless $valid_param_keys{$_};
    }
    
    my $package = caller;
    
    ${"$package\::__IS_ROLE__"} = 1;
    
    *{"$package\::import"} = sub {
        shift;   # Package name
        my %options = @_;

        for (keys %options) {
            croak "Unknown option ($_) for Class::Role" unless $valid_option_keys{$_};
        }
        
        my %exclude;
        if (ref($options{-excludes}) eq 'ARRAY') {
            %exclude = map { $_ => 1 } @{$options{-excludes}};
        }
        elsif ($options{-excludes} && !ref($options{-excludes})) {
            %exclude = ($options{-excludes} => 1);
        }
        elsif ($options{-excludes}) {
            croak "Unknown type for -excludes to Class::Role";
        }
        
        my (@methods, @conflicts);
        my $target = caller;
        my $roles = \%{"$target\::__ROLES__"};
        
        if (ref($param{-methods}) eq 'ARRAY') {
            @methods = @{$param{-methods}};
        }
        elsif ($param{-methods} && !ref $param{-methods}) {
            @methods = ($param{-methods});
        }
        elsif ($param{-methods}) {
            croak "Unknown type for -methods to Class::Role";
        }
        else {
            @methods = grep { 
                $_ ne 'import' && *{"$package\::$_"}{CODE} 
            } keys %{"$package\::"};
        }
        
        for my $method (@methods) {
            next if $exclude{$method};
            
            if (grep { $_ ne $package } @{$roles->{$method}}) { # Conflict
                push @{$roles->{$method}}, $package;
                push @conflicts, $method;
                next;
            }

            if (*{"$target\::$method"}{CODE}) {  # Override
                next;
            }
            
            if (${"$target\::__IS_ROLE__"}) {
                *{"$target\::$method"} = \&{"$package\::$method"};
            }
            else {
                eval <<EOC;
                    package $target;
                    *$method = sub { &$package\::$method };
EOC
            }
            push @{$roles->{$method}}, $package;
        }

        if (@conflicts) {
            if (!$options{-conflict} || lc $options{-conflict} eq 'die') {
                my $msg;
                for my $conflict (@conflicts) {
                    $msg .= "Role conflict in package $target:\n";
                    $msg .= "    $_\::$conflict\n" for @{$roles->{$conflict}};
                }
                die $msg;
            }
            elsif (lc $options{-conflict} eq 'exclude') {
                for (@conflicts) {
                    delete ${"$target\::"}{$_};
                    delete $roles->{$_};
                }
            }
            elsif (lc $options{-conflict} eq 'keep') {
                # Leave it alone
                for (@conflicts) {
                    $roles->{$_} = [ $roles->{$_}[0] ];
                }
            }
            elsif (lc $options{-conflict} eq 'replace' || 
                   lc $options{-conflict} eq 'mixin') {
                # Overwrite
                for (@conflicts) {
                    if (${"$target\::__IS_ROLE__"}) {
                        *{"$target\::$method"} = \&{"$package\::$method"};
                    }
                    else {
                        eval <<EOC;
                            package $target;
                            *$method = sub { &$package\::$method };
EOC
                    }
                    $roles->{$_} = [ $package ];
                }
            }
            else {
                croak "Unknown option to -conflict ('$options{-conflict}') to Class::Role";
            }
        }
    };
}

package PARENT;

sub AUTOLOAD {
    my $name = our $AUTOLOAD;
    $name =~ s/^.*:://;   # Rip off everything except for the method name
    
    my $self = shift;
    if (ref $self && !$builtin_types{ref $self}) {      # Method call, probably
        my $method = scalar(caller 1) . "::SUPER::$name";
        $self->$method(@_);     # XXX This stack frame shouldn't stick around...
    }
}

package Class::Role;

1;