—

              
package Type::Params::Alternatives;
use 5.008001;
use strict;
use warnings;
BEGIN {
        if ( $] < 5.010 ) { require Devel::TypeTiny::Perl58Compat }
}
BEGIN {
        $Type::Params::Alternatives::AUTHORITY  = 'cpan:TOBYINK';
        $Type::Params::Alternatives::VERSION    = '2.008001';
}
$Type::Params::Alternatives::VERSION =~ tr/_//d;
use B ();
use Eval::TypeTiny::CodeAccumulator;
use Types::Standard qw( -is -types -assert );
use Types::TypeTiny qw( -is -types to_TypeTiny );
my $Attrs = Enum[ qw/
        caller_level package subname description _is_signature_for ID
        method head tail parameters slurpy
        message on_die next fallback strictness is_named allow_dash method_invocant
        bless class constructor named_to_list list_to_named oo_trace
        class_prefix class_attributes
        returns_scalar returns_list
        want_details want_object want_source can_shortcut coderef
         
        sig_class base_options alternatives meta_alternatives
         
        quux mite_signature is_wrapper
/ ]; # quux for reasons
require Type::Params::Signature;
our @ISA = 'Type::Params::Signature';
sub new {
        my $class = shift;
        my %self  = @_ == 1 ? %{$_[0]} : @_;
        my $self = bless \%self, $class;
        $self->{next} ||= delete $self->{goto_next} if exists $self->{goto_next};
        exists( $self->{$_} ) || ( $self->{$_} = $self->{base_options}{$_} )
                for keys %{ $self->{base_options} };
        $self->{sig_class} ||= 'Type::Params::Signature';
        $self->{message}   ||= 'Parameter validation failed';
        delete $self->{base_options}{$_} for qw/ returns returns_list returns_scalar /;
        $self->_rationalize_returns;
        $Attrs->all( sort keys %$self ) or do {
                require Carp;
                require Type::Utils;
                my @bad = ( ~ $Attrs )->grep( sort keys %$self );
                Carp::carp( sprintf(
                        "Warning: unrecognized signature %s: %s, continuing anyway",
                        @bad == 1 ? 'option' : 'options',
                        Type::Utils::english_list( @bad ),
                ) );
        };
        return $self;
}
sub base_options      { $_[0]{base_options}      ||= {} }
sub alternatives      { $_[0]{alternatives}      ||= [] }
sub sig_class         { $_[0]{sig_class} }
sub meta_alternatives { $_[0]{meta_alternatives} ||= $_[0]->_build_meta_alternatives }
sub parameters        { [] }
sub next              { $_[0]{base_options}{next} }
sub goto_next         { $_[0]{base_options}{next} }
sub package           { $_[0]{base_options}{package}   }
sub subname           { $_[0]{base_options}{subname}   }
sub _build_meta_alternatives {
        my $self = shift;
        my $index = 0;
        return [
                map {
                        $self->_build_meta_alternative( $_, $index++ )
                } @{ $self->alternatives }
        ];
}
sub _build_meta_alternative {
        my ( $self, $alt, $index ) = @_;
        my $meta;
        if ( is_CodeRef $alt ) {
                $meta = { closure => $alt };
        }
        elsif ( is_HashRef $alt and exists $alt->{closure} ) {
                $meta = { %$alt };
        }
        elsif ( is_HashRef $alt ) {
                my %opts = (
                        %{ $self->base_options },
                        next            => !!0, # don't propagate these next few
                        returns         => undef,
                        returns_scalar  => undef,
                        returns_list    => undef,
                        %$alt,
                        want_source     => !!0,
                        want_object     => !!0,
                        want_details    => !!1,
                );
                $meta = $self->sig_class->new_from_v2api( \%opts )->return_wanted;
                $meta->{ID} = $alt->{ID} if exists $alt->{ID};
        }
        elsif ( is_ArrayRef $alt ) {
                my %opts = (
                        %{ $self->base_options },
                        next            => !!0, # don't propagate these next few
                        returns         => undef,
                        returns_scalar  => undef,
                        returns_list    => undef,
                        positional      => $alt,
                        want_source     => !!0,
                        want_object     => !!0,
                        want_details    => !!1,
                );
                $meta = $self->sig_class->new_from_v2api( \%opts )->return_wanted;
        }
        else {
                $self->_croak( 'Alternative signatures must be CODE, HASH, or ARRAY refs' );
        }
         
        $meta->{_index} = $index;
        return $meta;
}
sub _coderef_start_extra {
        my ( $self, $coderef ) = ( shift, @_ );
         
        $coderef->add_line( 'my $r;' );
        $coderef->add_line( 'undef ${^_TYPE_PARAMS_MULTISIG};' );
        $coderef->add_gap;
        for my $meta ( @{ $self->meta_alternatives } ) {
                $self->_coderef_meta_alternative( $coderef, $meta );
        }
         
        $self;
}
sub _coderef_meta_alternative {
        my ( $self, $coderef, $meta ) = ( shift, @_ );
         
        my @cond = '! $r';
        push @cond, sprintf( '@_ >= %s', $meta->{min_args} ) if defined $meta->{min_args};
        push @cond, sprintf( '@_ <= %s', $meta->{max_args} ) if defined $meta->{max_args};
        if ( defined $meta->{max_args} and defined $meta->{min_args} ) {
                splice @cond, -2, 2, sprintf( '@_ == %s', $meta->{min_args} )
                        if $meta->{max_args} == $meta->{min_args};
        }
         
        # It is sometimes possible to inline $meta->{source} here
        if ( $meta->{source}
        and $meta->{source} !~ /return/
        and ! keys %{ $meta->{environment} } ) {
                 
                my $alt_code = $meta->{source};
                $alt_code =~ s/^sub [{]/do {/;
                $coderef->add_line( sprintf(
                        'eval { local @_ = @_; $r = [ %s ]; ${^_TYPE_PARAMS_MULTISIG} = %s }%sif ( %s );',
                        $alt_code,
                        defined( $meta->{ID} )
                                ? B::perlstring( $meta->{ID} )
                                : ( 0 + $meta->{_index} ),
                        "\n\t",
                        join( ' and ', @cond ),
                ) );
                $coderef->add_gap;
        }
        else {
                 
                my $callback_var = $coderef->add_variable( '$signature', \$meta->{closure} );
                $coderef->add_line( sprintf(
                        'eval { $r = [ %s->(@_) ]; ${^_TYPE_PARAMS_MULTISIG} = %s }%sif ( %s );',
                        $callback_var,
                        defined( $meta->{ID} )
                                ? B::perlstring( $meta->{ID} )
                                : ( 0 + $meta->{_index} ),
                        "\n\t",
                        join( ' and ', @cond ),
                ) );
                $coderef->add_gap;
        }
         
        return $self;
}
sub _coderef_end_extra {
        my ( $self, $coderef ) = ( shift, @_ );
         
        $coderef->add_line( sprintf(
                '%s unless $r;',
                $self->_make_general_fail( message => B::perlstring( $self->{message} ) ),
        ) );
        $coderef->add_gap;
         
        return $self;
}
sub _coderef_check_count {
        shift;
}
sub _make_return_list {
        '@$r';
}
sub make_class_pp_code {
        my $self = shift;
         
        return join(
                qq{\n},
                grep { length $_ }
                map  { $_->{class_definition} || '' }
                @{ $self->meta_alternatives }
        );
}
1;
__END__
HideShow 82 lines of Pod
=pod
=encoding utf-8
=head1 NAME
Type::Params::Alternatives - subclass of Type::Params::Signature for C<multi> signatures
=head1 STATUS
This module is not covered by the
L<Type-Tiny stability policy|Type::Tiny::Manual::Policies/"STABILITY">.
=head1 DESCRIPTION
This is mostly internal code, but can be used to provide basic introspection
for signatures.
This module is a subclass of L<Type::Parameters::Signature>, so inherits
attributes and methods from that.
=head2 Constructor
=over
=item C<< new(%attributes) >>
=back
=head2 Attributes
All attributes are read-only.
=over
=item C<< base_options >> B<HashRef>
=item C<< alternatives >> B<< ArrayRef[HashRef|ArrayRef|CodeRef] >>
=item C<< sig_class >> B<ClassName>
=item C<< meta_alternatives >> B<ArrayRef[HashRef]>
Automatically built from C<alternatives>; do not set this yourself.
=item C<< parameters >> B<ArrayRef>
Overridden from parent class to always return the empty arrayref.
=item C<< message >> B<Str>
Error message to be thrown when none of the alternatives match.
This is a bare attribute with no accessor method.
=back
=head1 BUGS
Please report any bugs to
L<https://github.com/tobyink/p5-type-tiny/issues>.
=head1 SEE ALSO
L<Type::Params>, L<Type::Params::Signature>.
=head1 AUTHOR
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2023-2025 by Toby Inkster.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=head1 DISCLAIMER OF WARRANTIES
THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.