view release on metacpan or  search on metacpan

lib/Getopt/Chain/Declare.pm  view on Meta::CPAN

my %IMPORT_ARGUMENTS; # Yes, an ugly hack

{
    my ($import, $unimport) = Moose::Exporter->build_import_methods(
        with_caller => [qw/ start on rewrite under /],
        also => [qw/ Moose /],
    );

    sub import {
        my $class = shift; # 'under' or 'redispatch' or ...
        my $caller = caller();

        $IMPORT_ARGUMENTS{$caller} = [ @_ ];

        goto &$import;
    }

    no warnings 'once';
    *unimport = $unimport;
}

sub init_meta {
    shift;
    return Moose->init_meta( @_, base_class => 'Getopt::Chain', metaclass => 'Getopt::Chain::Declare::Branch::Meta::Class' );
}

sub start {
    my $caller = shift;
    $caller->meta->start( @_ );
}

sub on {
    my $caller = shift;
    $caller->meta->on( @_ );
}

sub under {
    my $caller = shift;
    $caller->meta->under( @_ );
}

sub rewrite {
    my $caller = shift;
    $caller->meta->rewrite( @_ );
}

1;

package Getopt::Chain::Declare::Branch::Meta::Class;

use Moose;
use Getopt::Chain::Carp;

extends qw/Moose::Meta::Class/;

has getopt_chain_parent_class => qw/is ro lazy_build 1/;
sub _build_getopt_chain_parent_class {
    my $self = shift;
    my ($class) = $self->linearized_isa;
    my @class = split m/::/, $class;
    pop @class;
    join '::', @class;
}

sub getopt_chain_parent_meta {
    return shift->getopt_chain_parent_class->meta;
}

sub import_arguments {
    my $self = shift;

    my ($class) = $self->linearized_isa;
    
    croak "No import arguments for \"$class\"" unless my $arguments = $IMPORT_ARGUMENTS{$class};

    return @$arguments;
}

has recorder => qw/is ro lazy_build 1/, handles => [qw/ do_or_record /];
sub _build_recorder {
    require Getopt::Chain::Declare;
    return Getopt::Chain::Declare::Recorder->new;
}

sub replay {
    my $self = shift;
    my $parent_builder = shift;

    my @arguments = $self->import_arguments;
    my $match = $arguments[0];

    # We *could* redispatch here, but ...
    $parent_builder->under( $match => sub {
        $self->recorder->replay( $parent_builder );
    } );
}

has registered => qw/is rw default 0/;
before do_or_record => sub {
    my $self = shift;
    return if $self->registered;
    $self->getopt_chain_parent_meta->recorder->record( $self ); # "Register" ourself
    $self->registered( 1 );
};

sub start { shift->do_or_record( start => @_ ) }
sub on { shift->do_or_record( on => @_ ) }
sub under { shift->do_or_record( under => @_ ) }
sub rewrite { shift->do_or_record( rewrite => @_ ) }

1;