File Coverage

blib/lib/Blosxom/Plugin.pm

Criterion	Covered	Total	%
statement	132	135	97.7
branch	40	46	86.9
condition	7	9	77.7
subroutine	25	25	100.0
pod	6	8	75.0
total	210	223	94.1

package Blosxom::Plugin;
use 5.008_009;
use strict;
use warnings;
use Carp qw/croak/;

our $VERSION = '0.02004';

sub import {
    my $class     = shift;
    my $component = scalar caller;
    my $stash     = do { no strict 'refs'; \%{"$component\::"} };

    my %is_excluded;
    while ( my ($method, $glob) = each %{$stash} ) {
        next unless defined *{$glob}{CODE};
        $is_excluded{$method}++;
    }

    my ( @requires, @accessors );

    my @exports = (
        requires => sub { shift; push @requires, @_ },
        mk_accessors => sub {
            my $pkg = shift;
            my @args = ref $_[0] eq 'HASH' ? %{$_[0]} : map { $_ => undef } @_;
            push @accessors, @args,
        },
        init => sub {
            my ( $comp, $plugin ) = @_;

            if ( my @methods = grep { !$plugin->can($_) } @requires ) {
                my $methods = join ', ', @methods;
                croak "Can't apply '$comp' to '$plugin' - missing $methods";
            }

            for ( my $i = 0; $i < @accessors; $i += 2 ) {
                $plugin->add_attribute( @accessors[$i, $i+1] );
            }

            while ( my ($method, $glob) = each %{$stash} ) {
                if ( my $code = *{$glob}{CODE} ) {
                    next if $is_excluded{$method};
                    $plugin->add_method( $method => $code );
                }
            }

            return;
        },
    );

    # export mixin methods
    no strict 'refs';
    while ( my ( $method, $code ) = splice @exports, 0, 2 ) {
        *{ "$component\::$method" } = $code;
        $is_excluded{ $method }++;
    }

    return;
}

my %attribute_of;

sub mk_accessors {
    my $package   = shift;
    my @accessors = ref $_[0] eq 'HASH' ? %{ $_[0] } : map { $_ => undef } @_;

    no strict 'refs';
    while ( my ($field, $default) = splice @accessors, 0, 2 ) {
        *{"$package\::$field"} = $package->make_accessor($field, $default);
    }

    return;
}

sub make_accessor {
    my $package   = shift;
    my $name      = shift;
    my $default   = shift;
    my $attribute = $attribute_of{$package} ||= {};

    if ( ref $default eq 'CODE' ) {
        return sub {
            return $attribute->{$name} = $_[1] if @_ == 2;
            return $attribute->{$name} if exists $attribute->{$name};
            return $attribute->{$name} = $package->$default;
        };
    }
    elsif ( defined $default ) {
        return sub {
            return $attribute->{$name} = $_[1] if @_ == 2;
            return $attribute->{$name} if exists $attribute->{$name};
            return $attribute->{$name} = $default;
        };
    }
    else {
        return sub {
            @_ > 1 ? $attribute->{$name} = $_[1] : $attribute->{$name};
        };
    }

    return;
}

sub end { %{ $attribute_of{$_[0]} } = () if exists $attribute_of{$_[0]} }

sub dump {
    my $package = shift;
    require Data::Dumper;
    local $Data::Dumper::Maxdepth = shift || 1;
    Data::Dumper::Dumper( $attribute_of{$package} );
}

sub component_base_class { __PACKAGE__ }

sub load_components {
    my $package = shift;
    my @args    = @_;
    my $prefix  = $package->component_base_class;

    my ( $component, %is_loaded, %has_conflict, %code_of );

    local *add_component
        = sub { push @args, @_ > 2 ? @_[1, 2] : $_[1] };

    local *add_method = sub {
        my ( $pkg, $method, $code ) = @_;
        unless ( defined &{"$package\::$method"} ) {
            push @{ $has_conflict{$method} ||= [] }, $component;
            $code_of{ $method } = $code;
        }
    };

    while ( @args ) {
        $component = do {
            my $class = shift @args;

            if ( $class !~ s/^\+// and $class !~ /^$prefix/ ) {
                $class = "$prefix\::$class";
            }

            if ( $is_loaded{$class}++ ) {
                shift @args if ref $args[0] eq 'HASH';
                next;
            }

            ( my $file = $class ) =~ s{::}{/}g;
            require "$file.pm";

            $class;
        };

        my $config = ref $args[0] eq 'HASH' ? shift @args : undef;

        $component->init( $package, $config );
    }

    if ( %code_of ) {
        no strict 'refs';
        while ( my ( $method, $components ) = each %has_conflict ) {
            delete $has_conflict{ $method } if @{ $components } == 1;
            *{ "$package\::$method" } = $code_of{ $method };
        }
    }

    if ( %has_conflict ) {
        croak join "\n", map {
            "Due to a method name conflict between components " .
            "'" . join( ' and ', sort @{ $has_conflict{$_} } ) . "', " .
            "the method '$_' must be implemented by '$package'";
        } keys %has_conflict;
    }

    return;
}

sub add_attribute {
    my ( $pkg, $name, $default ) = @_;
    $pkg->add_method( $name => $pkg->make_accessor($name, $default) );
}

sub has_method { defined &{"$_[0]::$_[1]"} }

1;

__END__