File Coverage

blib/lib/Brickyard.pm

Criterion	Covered	Total	%
statement	126	133	94.7
branch	46	58	79.3
condition	4	4	100.0
subroutine	17	18	94.4
pod	8	8	100.0
total	201	221	90.9

use 5.010;
use warnings;
use strict;

package Brickyard;
BEGIN {
  $Brickyard::VERSION = '1.111750';
}

# ABSTRACT: Plugin system based on roles
use Brickyard::Accessor rw =>
  [qw(base_package expand plugins plugins_role_cache)];
use Carp qw(croak);

sub new {
    my $class = shift;
    bless {
        base_package       => 'MyApp',
        expand             => [],
        plugins            => [],
        plugins_role_cache => {},
        @_
    }, $class;
}

sub plugins_with {
    my ($self, $role) = @_;
    $role = $self->expand_package($role);
    $self->plugins_role_cache->{$role} ||=
      [ grep { $_->DOES($role) } @{ $self->plugins } ];
    @{ $self->plugins_role_cache->{$role} };
}

sub plugins_agree {
    my ($self, $role, $code) = @_;
    my @plugins = $self->plugins_with($role);
    return unless @plugins;
    for (@plugins) {

        # $code can use $_->foo($bar)
        return unless $code->();
    }
    1;
}

sub reset_plugins {
    my $self = shift;
    $self->plugins([]);
    $self->plugins_role_cache({});
}

sub parse_ini {
    my ($self, $ini, $callback) = @_;
    $callback //= sub { $_[0] };    # default: identity function
    my @result = ([ '_', '_', {} ]);
    my $counter = 0;
    foreach (split /(?:\015{1,2}\012|\015|\012)/, $ini) {
        $counter++;
        next if /^\s*(?:\#|\;|$)/;    # Skip comments and empty lines
        s/\s\;\s.+$//g;               # Remove inline comments

        # Handle section headers
        if (/^\s*\[\s*(.+?)\s*\]\s*$/) {
            push @result, [ $1, $1, {} ];
            next;
        }

        # Handle properties
        if (/^\s*([^=]+?)\s*=\s*(.*?)\s*$/) {
            my ($key, $value) = ($1, $2);
            $value = $callback->($value);
            my $section = $result[-1][2];

            # if a property is seen multiple times, it becomes an array
            if (exists $section->{$key}) {
                $section->{$key} = [ $section->{$key} ]
                  unless ref $section->{$key} eq 'ARRAY';
                push @{ $section->{$key} } => $value;
            } else {
                $section->{$key} = $value;
            }
            next;
        }
        die "Syntax error in INI file at line $counter: '$_'";
    }
    \@result;
}

# appropriated from CGI::Expand
sub _expand_hash {
    my $flat = $_[1];
    my $deep = {};
    for my $name (keys %$flat) {
        my ($first, @segments) = split /\./, $name;
        my $box_ref = \$deep->{$first};
        for (@segments) {
            if (/^(0|[1-9]\d*)$/) {
                $$box_ref = [] unless defined $$box_ref;
                croak "param clash for $name($_)"
                  unless ref $$box_ref eq 'ARRAY';
                $box_ref = \($$box_ref->[$1]);
            } else {
                $$box_ref = {} unless defined $$box_ref;
                croak "param clash for $name($_)"
                  unless ref $$box_ref eq 'HASH';
                $box_ref = \($$box_ref->{$_});
            }
        }
        croak "param clash for $name value $flat->{$name}"
          if defined $$box_ref;
        $$box_ref = $flat->{$name};
    }
    $deep;
}

sub expand_package {
    my $self = shift;
    local $_ = shift;
    my $base = s/^\*// ? 'Brickyard' : $self->base_package;
    return $_ if s/^@(?=\w)/$base\::PluginBundle::/;
    return $_ if s/^-(?=\w)/$base\::Role::/;
    return $_ if s/^=(?=\w)//;
    for my $expand (@{ $self->expand }) {
        my $before = $_;
        eval $expand;
        return $_ if $_ ne $before;
        die $@ if $@;
    }
    "$base\::Plugin::$_";
}

sub _read_config_file {
    my ($self, $file) = @_;
    open my $fh, '<', $file or die "can't open $file for reading: $!\n";
    my $config = do { local $/; <$fh> };
    close $fh or die "can't close $file: $!\n";
    $config;
}

sub _merge_configs {
    my ($self, $merged_config, $new_config) = @_;
    return $new_config unless ref $merged_config eq 'ARRAY';
    for my $new_section (@$new_config) {
        my ($local_name, $plugin_config) = @{$new_section}[0,2];
        if ($local_name eq '_') {
            # assume the merged config's root section is at the start
            $merged_config->[0][2] = {
                %{ $merged_config->[0][2] },
                %$plugin_config
            };
        } else {
            push @$merged_config => $new_section;
        }
    }
    $merged_config;
}

sub init_from_config {
    my ($self, $config, $root, $callback) = @_;
    if (ref $config eq 'SCALAR') {
        # $config is a reference to the INI string
        my $this_config = $self->parse_ini($$config, $callback);
        $_->[2] = $self->_expand_hash($_->[2]) for @$this_config;
        $self->init_from_config_structure($this_config, $root, $callback);
    } else {
        # $config is a filename
        my $merged_config;
        my @files = split /:/ => $config;
        for my $file (@files) {
            my $this_config = $self->parse_ini($self->_read_config_file($file), $callback);
            $_->[2] = $self->_expand_hash($_->[2]) for @$this_config;
            $merged_config = $self->_merge_configs($merged_config, $this_config);
        }
        $self->init_from_config_structure($merged_config, $root, $callback);
    }
}

sub init_from_config_structure {
    my ($self, $config, $root, $callback) = @_;
    for my $section (@$config) {
        my ($local_name, $name, $plugin_config) = @$section;
        if ($local_name eq '_') {

            # Global container configuration
            while (my ($key, $value) = each %$plugin_config) {
                if ($key eq 'expand') {
                    push @{ $self->expand },
                      ref $value eq 'ARRAY' ? @$value : $value;
                } else {
                    $root->$key($value);
                }
            }
        } else {
            my $package = $section->[1] = $self->expand_package($name);
            eval "require $package";
            die "Cannot require $package: $@" if $@;
            if ($package->DOES('Brickyard::Role::PluginBundle')) {
                my $bundle = $package->new(brickyard => $self, %$plugin_config);
                $self->init_from_config_structure($bundle->bundle_config, $root);
            } else {
                push @{ $self->plugins } => $package->new(
                    name      => $local_name,
                    brickyard => $self,
                    %$plugin_config
                );
            }
        }
    }
}
1;


__END__