view release on metacpan or  search on metacpan

lib/Dios/Types/Pure.pm  view on Meta::CPAN

            my $sig2 = $sigs[$index_2]{sig};
            my $narrowness =
                $narrowness_for{$sig1,$sig2} //= _cmp_signatures($sig1, $sig2);

            if    ($narrowness < 0) { push @{$narrower{$index_1}}, $index_2; }
            elsif ($narrowness > 0) { push @{$narrower{$index_2}}, $index_1; }
        }
    }

    # Find the narrowest signature(s)...
    my $max_narrower = max map { scalar @{$_} } values %narrower;

    # If they're not sufficiently narrow, weed out the non-contenders...
    if ($max_narrower < @sigs-1) {
        @sigs = @sigs[ sort grep { @{$narrower{$_}} } keys %narrower ];
    }
    # Otherwise, locate the narrowest...
    else {
        @sigs = @sigs[ first { @{$narrower{$_}} >= $max_narrower } keys %narrower ];
    }

    # Tie-break methods on the class of the variants...
    if ($kind eq 'method' && @sigs > 1) {
        @sigs = sort { $a->{class} eq $b->{class}    ?  0
                     : $a->{class}->isa($b->{class}) ? -1
                     : $b->{class}->isa($a->{class}) ? +1
                     :                                  0
                     } @sigs;
        @sigs = grep { $_->{class} eq $sigs[0]{class} } @sigs;
    }

    return @sigs;
}


sub _describe_constraint {
    my ($value, $value_desc, $constraint, $constraint_desc) = @_;

    # Did the exception provide a constraint description???
    if ($constraint_desc) {
        $constraint_desc =~ s{\b at .* line .*+ \s*+}{}gx;
    }

    # Describe the value that failed...
    $value_desc = _complete_desc($value_desc, $value);

    # Try to describe the constraint by name, if it was a named sub...
    if (!length($constraint_desc//q{}) && eval{ require B }) {
        my $sub_name = B::svref_2object($constraint)->GV->NAME;
        if ($sub_name && $sub_name ne '__ANON__') {
            $sub_name =~ s/[:_]++/ /g;
            $constraint_desc = $sub_name;
        }
    }

    # Deparse the constraint sub (if necessary and possible)...
    if (!length($constraint_desc//q{}) && eval{ require B::Deparse }) {
        state $deparser = B::Deparse->new;
        my ($hint_bits, $warning_bits) = (caller 0)[8,9];
        $deparser->ambient_pragmas(
            hint_bits => $hint_bits, warning_bits => $warning_bits, # '$[' => 0 + $[
        );
        $constraint_desc = $deparser->coderef2text($constraint);
        $constraint_desc =~ s{\s*+ BEGIN \s*+ \{ (?&CODE) \}
                                (?(DEFINE) (?<CODE> [^{}]*+ (\{ (?&CODE) \} [^{}]*+ )*+ ))}{}gxms;
        $constraint_desc =~ s{(?: (?:use|no) \s*+ (?: feature | warnings | strict ) | die \s*+ sprintf ) [^;]* ;}{}gxms;
        $constraint_desc =~ s{package \s*+ \S+ \s*+ ;}{}gxms;
        $constraint_desc =~ s{\s++}{ }g;
    }
    return $constraint_desc // "$constraint";
}

sub _perl {
    use Data::Dump 'dump';
    dump( map {
            if    (my $tiedclass = tied $_)    { $tiedclass =~ s/=.*//; "<$tiedclass tie>" }
            elsif (my $classname = blessed $_) { "<$classname object>"      }
            else                               { $_ }
          } @_ )
        =~ s{" (< \S++ \s (?:object|tie) >) "}{$1}xgmsr;

}



1; # Magic true value required at end of module
__END__

=head1 NAME

Dios::Types::Pure - Type checking for the Dios framework (and everyone else too)


=head1 VERSION

This document describes Dios::Types::Pure version 0.000001


=head1 SYNOPSIS

    use Dios::Types::Pure 'validate';

    # Throw an exception if the VALUE doesn't conform to the specified TYPE
    validate($TYPE, $VALUE);

    # Same, but report errors using the specified MESSAGE
    validate($TYPE, $VALUE, $MESSAGE);

    # Same, but VALUE must satisfy every one of the CONSTRAINTS as well
    validate($TYPE, $VALUE, $DESC, @CONSTRAINTS);

    # If you don't want exceptions in response to type mismatches, use an eval
    if (eval{ validate($TYPE, $VALUE) }) {
        warn "$VALUE not of type $TYPE. Proceeding anyway.";
    }

    use Dios::Types::Pure 'validator_for';

    # Same, but prebuild validator for faster checking...
    my $check = validator_for($TYPE, $DESC, @CONSTRAINTS);