File Coverage

blib/lib/Code/Style/Kit.pm

Criterion	Covered	Total	%
statement	112	119	94.1
branch	19	26	73.0
condition	11	15	73.3
subroutine	19	19	100.0
pod	3	3	100.0
total	164	182	90.1

package Code::Style::Kit;
use strict;
use warnings;
use Data::OptList;
use Import::Into;
use Carp;
use mro ();
use Package::Stash qw(get_all_symbols);
use Module::Runtime qw(use_module);

use constant DEBUG => $ENV{CODE_STYLE_KIT_DEBUG};

our $VERSION = '1.0.2'; # VERSION
# ABSTRACT: build composable bulk exporters


sub import {
    my $class = shift;
    my $caller = caller();

    my $self = $class->_new($caller,@_);
    $self->_export_features;
    return;
}


sub is_feature_requested {
    my ($self, $feature) = @_;
    return !! $self->{requested_features}{$feature};
}


sub also_export {
    my ($self, $feature, $args) = @_;
    local $self->{requested_features}{$feature} = $args || [];
    $self->_export_one_feature($feature, 1);
    return;
}


sub maybe_also_export {
    my ($self, $feature, $args) = @_;
    local $self->{requested_features}{$feature} = $args || [];
    $self->_export_one_feature($feature, 0);
    return;
}

# private constructor, invoked from C
sub _new {
    my ($class,$caller,@args) = @_;

    # get all the parts in C<@ISA> order
    my $parent_stashes = $class->_get_parent_stashes;
    # get the features they provide by default
    my %feature_set = map { $_ => [] } $class->_default_features($parent_stashes);

    my $args = Data::OptList::mkopt(\@args,{
        moniker => $class,
        must_be => 'ARRAY',
        require_unique => 1,
    });
    # interpret the import arguments
    for my $arg (@{$args}) {
        my ($key, $value) = @{$arg};

        if ($key =~ /^-(\w+)$/) {
            if ($value) {
                croak "providing import arguments (@{$value}) when removing a feature ($1) makes no sense";
            }
            print STDERR "$class - removing feature $1\n" if DEBUG;
            delete $feature_set{$1};
        }
        elsif ($key =~ /^\w+$/) {
            print STDERR "$class - adding feature $key\n" if DEBUG;
            $feature_set{$key} = $value // [];
        }
        else {
            croak "malformed feature <$key> when importing $class";
        }
    }

    # build the instance
    return bless {
        caller => $caller,
        feature_list => [ $class->_sort_features(keys %feature_set) ],
        requested_features => \%feature_set,
        exported_features => {},
        # we save this, so ->_export_one_feature doesn't have to scan
        # the parts again
        parent_stashes => $parent_stashes,
    }, $class;
}

sub _export_features {
    my ($self) = @_;

    for my $feature (@{$self->{feature_list}}) {
        $self->_export_one_feature($feature, 1);
    }
}

# all the magic is from here to the end

# the actual exporting
sub _export_one_feature {
    my ($self, $feature, $croak_if_not_implemented) = @_;
    my $class = ref($self);
    my @import_args = @{ $self->{requested_features}{$feature} || [] };

    print STDERR "$class - exporting $feature to $self->{caller} with arguments (@import_args)\n"
        if DEBUG;

    # do nothing if we've exported it already
    return if $self->{exported_features}{$feature};

    my $list_method = "feature_${feature}_export_list";
    my $direct_method = "feature_${feature}_export";

    my $arguments_method = "feature_${feature}_takes_arguments";
    my $takes_arguments = $self->can($arguments_method) && $self->$arguments_method;
    if (@import_args && !$takes_arguments) {
        croak "feature $feature does not take arguments, but (@import_args) were provided";
    }

    my $provided = 0;
    # loop over the parts in @ISA order
    for my $parent_stash (@{$self->{parent_stashes}}) {
        my $parent_class = $parent_stash->name;
        my $method_ref;
        # does this part provide a *_export_list sub?
        if ($method_ref = $parent_stash->get_symbol("&$list_method")) {
            print STDERR "  calling ${parent_class}->$list_method\n"
                if DEBUG;
            # import all the packages that the sub returns
            for my $module ($self->$method_ref) {
                use_module($module)->import::into($self->{caller}, @import_args);
            }
            $provided = 1;
        }
        # does this part provide a *_export sub?
        elsif ($method_ref = $parent_stash->get_symbol("&$direct_method")) {
            print STDERR "  calling ${parent_class}->$direct_method\n"
                if DEBUG;
            # call it and let it do whatever it needs to
            $self->$method_ref($self->{caller},@import_args);
            $provided = 1;
        }
    }

    # did we find the feature?
    if ($provided) {
        # mark it as exported
        $self->{exported_features}{$feature} = 1;
    }
    elsif ($croak_if_not_implemented) {
        # croak if asked to
        croak "feature <$feature> is not implemented by $class";
    }

    return;
}

# use the *_order subs
sub _sort_features {
    my ($class, @features) = @_;

    my %feature_sort_key = map {
        my $method = "feature_${_}_order";
        $_ => ( $class->can($method) ? $class->$method : 100 )
    } @features;

    @features = sort {
        $feature_sort_key{$a} <=> $feature_sort_key{$b}
    } @features;

    print "$class - sorted features: (@features)\n" if DEBUG;

    return @features;
}

# use the *_default subs
sub _default_features {
    my ($class, $parent_stashes) = @_;

    my @features;
    # loop over the parts in @ISA order
    for my $parent_stash (@{$parent_stashes}) {
        my @subs = $parent_stash->list_all_symbols('CODE');
        for my $sub (@subs) {
            # we only care about sub names of this form
            next unless $sub =~ /^feature_(\w+)_default$/;

            my $feature = $1;
            my $is_default = $class->$sub;

            if (DEBUG) {
                my $parent_class = $parent_stash->name;
                print STDERR "$class - $parent_class provides $feature, by default ",
                    ($is_default ? 'enabled' : 'disabled' ),
                    "\n";
            }

            push @features, $feature if $is_default;
        }
    }

    return @features;
}

sub _get_parent_stashes {
    my ($class) = @_;

    $class = ref($class) || $class;
    return [ map { Package::Stash->new($_) } @{ mro::get_linear_isa($class) } ];
}

1;

__END__