File Coverage

blib/lib/Getopt/Yath.pm

Criterion	Covered	Total	%
statement	64	71	90.1
branch	10	22	45.4
condition	6	16	37.5
subroutine	13	15	86.6
pod			n/a
total	93	124	75.0

package Getopt::Yath;
use strict;
use warnings;

our $VERSION = '2.000008';

use Carp qw/croak/;

use Getopt::Yath::Util qw/mod2file/;

use Getopt::Yath::Instance;
use Getopt::Yath::Option;

sub import {
    my $class  = shift;
    my %params = @_;

    my $caller = caller();

    my $inst_class = $params{inst_class} // 'Getopt::Yath::Instance';

    my $instance = $inst_class->new(class => $class);
    $instance->include($class->options) if $params{inherit} && $class->can('options');

    my %export;
    my @common;
    $export{options} = sub { $instance };

    $export{option} = sub {
        my $title = shift;
        my $option = Getopt::Yath::Option->create(trace => [caller()], title => $title, @common ? (%{$common[-1]}) : (), @_);
        $instance->_option($option);
    };

    $export{include_options} = sub {
        while (my $module = shift @_) {
            my $file = mod2file($module);
            require $file unless $INC{$file};

            croak "Module '$module' does not have an 'options' method"
                unless $module->can('options');

            my $list = @_ && ref($_[0]) eq 'ARRAY' ? shift(@_) : undef;

            $instance->include($module->options, $list);
        }
    };

    $export{option_post_process} = sub {
        my $cb           = pop;
        my $weight       = shift // 0;
        my ($applicable) = @_;

        $applicable //= $common[-1]->{applicable} if @common;

        croak "You must provide a callback coderef" unless $cb && ref($cb) eq 'CODE';

        $instance->_post([caller()], $weight, $applicable, $cb);
    };

    $export{option_group} = sub {
        my ($set, $sub) = @_;

        my $common = {@common ? (%{$common[-1]}) : (), %$set};

        $common->{module} = caller unless $common->{no_module};

        push @common => $common;
        my $ok  = eval { $sub->(); 1 };
        my $err = $@;
        pop @common;

        die $err unless $ok;
    };

    $export{parse_options} = sub { $instance->process_args(@_) };

    $export{category_sort_map} = sub { $instance->set_category_sort_map(@_) };

    for my $name (keys %export) {
        no strict 'refs';
        croak "$caller already has an '$name' method"
            if defined(&{"${caller}\::${name}"});

        *{"${caller}\::${name}"} = $export{$name};
    }

    return 1;
}

1;

__END__