From 6cddeeeb25eecb89ecd5958483f9462d7785374f Mon Sep 17 00:00:00 2001 From: Toby Inkster Date: Wed, 28 May 2025 09:09:38 +0100 Subject: [PATCH 1/2] Handy methods for Type::Params $arg objects --- lib/Type/Params.pm | 38 +++++ lib/Type/Params/Signature.pm | 82 +++++++++++ lib/Types/Standard.pm | 12 ++ t/20-modules/Type-Params/v2-named-methods.t | 154 ++++++++++++++++++++ 4 files changed, 286 insertions(+) create mode 100644 t/20-modules/Type-Params/v2-named-methods.t diff --git a/lib/Type/Params.pm b/lib/Type/Params.pm index 4c592430..43b1c81c 100644 --- a/lib/Type/Params.pm +++ b/lib/Type/Params.pm @@ -586,6 +586,44 @@ function as a single parameter object: say add_numbers( num1 => 2, num2 => 3 ); # says 5 say add_numbers( { num1 => 2, num2 => 3 } ); # also says 5 +Since Type::Params 2.009_000 the C<< $arg >> object has methods called +C<< __TO_LIST__ >>, C<< __TO_ARRAYREF__ >>, and C<< __TO_HASHREF__ >>. + + signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] ); + sub add_numbers ( $arg ) { + my ( $num1, $num2 ) = $arg->__TO_LIST__; + return $num1 + $num2; + } + + signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] ); + sub add_numbers ( $arg ) { + my $nums = $arg->__TO_ARRAYREF__; + return $nums[0] + $nums[1]; + } + + signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] ); + sub add_numbers ( $arg ) { + my $nums = $arg->__TO_HASHREF__; + return $nums->{num1} + $nums->{num2}; + } + +Each of these can be given an optional arrayref indicating which fields to +return. + + signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] ); + sub add_numbers ( $arg ) { + my ( $num2, $num1 ) = $arg->__TO_LIST__( [ qw/ num2 num1 / ] ); + return $num1 + $num2; + } + +The arrayref accepts aliases (see C) but methods may throw an +exception if the arrayref contains unknown field names. (See +C to control whether an exception is thrown.) + +These methods start and end with double underscores to reduce the chance +that they'll conflict with the name of a named parameter, however they are +considered part of the public, supported API. + =head4 C<< named_to_list >> B<< ArrayRef|Bool >> The C option is ignored for signatures using positional diff --git a/lib/Type/Params/Signature.pm b/lib/Type/Params/Signature.pm index 64a9ef43..9d8f4ab9 100644 --- a/lib/Type/Params/Signature.pm +++ b/lib/Type/Params/Signature.pm @@ -1083,6 +1083,8 @@ sub make_class_xs { replace => 1, %$attr, ); + + $self->make_extra_methods; } sub make_class_pp { @@ -1093,6 +1095,8 @@ sub make_class_pp { local $@; eval( $code ) or die( $@ ); }; + + $self->make_extra_methods; } sub make_class_pp_code { @@ -1135,6 +1139,84 @@ sub make_class_pp_code { return $coderef->code; } +sub make_extra_methods { + my $self = shift; + + my @parameters = @{ $self->parameters }; + if ( $self->has_slurpy ) { + push @parameters, $self->slurpy; + } + + my $coderef = $self->_new_code_accumulator; + $coderef->add_line( '{' ); + $coderef->{indent} = "\t"; + $coderef->add_line( sprintf( 'package %s;', $self->bless ) ); + $coderef->add_line( 'use strict;' ); + $coderef->add_line( 'no warnings;' ); + + $coderef->add_line( 'my @FIELDS = (' ); + for my $p ( @parameters ) { + $coderef->add_line( "\t" . B::perlstring( $p->name ) . "," ) + } + $coderef->add_line( ');' ); + + my @enum; + $coderef->add_line( 'my %FIELDS = (' ); + for my $p ( @parameters ) { + $coderef->add_line( "\t" . B::perlstring( $p->name ) . " => " . B::perlstring( $p->name ) . "," ); + for my $p2 ( $p->_all_aliases($self) ) { + $coderef->add_line( "\t" . B::perlstring( $p2 ) . " => " . B::perlstring( $p->name ) . "," ); + } + push @enum, $p->name, $p->_all_aliases($self); + } + $coderef->add_line( ');' ); + my $enum = ArrayRef[ Enum[ @enum ] ]; + + $coderef->add_line( 'sub __TO_LIST__ {' ); + $coderef->add_line( "\t" . 'my ( $arg, $fields ) = @_;' ); + $coderef->add_line( "\t" . 'return map $arg->{$_}, @FIELDS if not defined $fields;' ); + if ( ( defined $self->strictness and $self->strictness eq 1 ) or not $self->has_strictness ){ + $coderef->add_line( "\t" . $enum->inline_assert( '$fields' ) ); + } + elsif ( $self->strictness ) { + $coderef->add_line( "\t" . sprintf( 'if ( %s ) { %s }', $self->strictness, $enum->inline_assert( '$fields' ) ) ); + } + $coderef->add_line( "\t" . 'return map $arg->{$FIELDS{$_}}, @$fields;' ); + $coderef->add_line( '}' ); + + $coderef->add_line( 'sub __TO_ARRAYREF__ {' ); + $coderef->add_line( "\t" . 'my ( $arg, $fields ) = @_;' ); + $coderef->add_line( "\t" . 'return [ map $arg->{$_}, @FIELDS ] if not defined $fields;' ); + if ( ( defined $self->strictness and $self->strictness eq 1 ) or not $self->has_strictness ){ + $coderef->add_line( "\t" . $enum->inline_assert( '$fields' ) ); + } + elsif ( $self->strictness ) { + $coderef->add_line( "\t" . sprintf( 'if ( %s ) { %s }', $self->strictness, $enum->inline_assert( '$fields' ) ) ); + } + $coderef->add_line( "\t" . 'return [ map $arg->{$FIELDS{$_}}, @$fields ];' ); + $coderef->add_line( '}' ); + + $coderef->add_line( 'sub __TO_HASHREF__ {' ); + $coderef->add_line( "\t" . 'my ( $arg, $fields ) = @_;' ); + $coderef->add_line( "\t" . 'return +{ map { ; $_ => $arg->{$_} } @FIELDS } if not defined $fields;' ); + if ( ( defined $self->strictness and $self->strictness eq 1 ) or not $self->has_strictness ){ + $coderef->add_line( "\t" . $enum->inline_assert( '$fields' ) ); + } + elsif ( $self->strictness ) { + $coderef->add_line( "\t" . sprintf( 'if ( %s ) { %s }', $self->strictness, $enum->inline_assert( '$fields' ) ) ); + } + $coderef->add_line( "\t" . 'return +{ map { ; $_ => $arg->{$FIELDS{$_}} } @$fields };' ); + $coderef->add_line( '}' ); + + $coderef->add_line( '1;' ); + $coderef->{indent} = ""; + $coderef->add_line( '}' ); + + my $code = $coderef->code; + local $@; + eval( $code ) or die( $@ ); +} + sub return_wanted { my $self = shift; my $coderef = $self->coderef; diff --git a/lib/Types/Standard.pm b/lib/Types/Standard.pm index 2dacf287..0a4f6652 100644 --- a/lib/Types/Standard.pm +++ b/lib/Types/Standard.pm @@ -1355,6 +1355,10 @@ length can be given: Other customers also bought: B<< ArrayLike >> from L. +Notice: future versions of Types::Standard are likely to introduce +coercions to B from B<< HasMethods['__TO_ARRAYREF__'] >> and +from B. + =item * B<< HashRef[`a] >> @@ -1369,6 +1373,10 @@ constrain the hash values. Other customers also bought: B<< HashLike >> from L. +Notice: future versions of Types::Standard are likely to introduce +coercions to B from B<< HasMethods['__TO_HASHREF__'] >> and +from B. + =item * B<< CodeRef >> @@ -1377,6 +1385,10 @@ A value where C<< ref($value) eq "CODE" >>. Other customers also bought: B<< CodeLike >> from L. +Notice: future versions of Types::Standard are likely to introduce +coercions to B from B<< HasMethods['__TO_CODEREF__'] >> and +from B. + =item * B<< RegexpRef >> diff --git a/t/20-modules/Type-Params/v2-named-methods.t b/t/20-modules/Type-Params/v2-named-methods.t new file mode 100644 index 00000000..4f80604f --- /dev/null +++ b/t/20-modules/Type-Params/v2-named-methods.t @@ -0,0 +1,154 @@ +=pod + +=encoding utf-8 + +=head1 PURPOSE + +Named parameter tests for modern Type::Params v2 API. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2022-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. + +=cut + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::TypeTiny; + +use Types::Common -all; + +our @ARGS; + +signature_for [ qw/ get_list get_arrayref get_hashref / ] => ( + named => [ + foo => Int, { alias => 'fool' }, + bar => Optional[Int], + ], +); + +sub get_list { + shift->__TO_LIST__( @ARGS ); +} + +subtest '__TO_LIST__' => sub { + + is_deeply( + [ get_list( foo => 66, bar => 99 ) ], + [ 66, 99 ], + ); + + local @ARGS = ( [ qw/ foo foo bar foo / ] ); + is_deeply( + [ get_list( foo => 66, bar => 99 ) ], + [ 66, 66, 99, 66 ], + ); + + local @ARGS = ( [ qw/ foo / ] ); + is_deeply( + [ get_list( foo => 66, bar => 99 ) ], + [ 66 ], + ); + + local @ARGS = ( [ qw/ bar fool / ] ); + is_deeply( + [ get_list( foo => 66, bar => 99 ) ], + [ 99, 66 ], + ); + + local @ARGS = ( [ qw/ BAR / ] ); + isnt( + exception { get_list( foo => 66, bar => 99 ) }, + undef, + ); +}; + +sub get_arrayref { + shift->__TO_ARRAYREF__( @ARGS ); +} + +subtest '__TO_ARRAYREF__' => sub { + + is_deeply( + get_arrayref( foo => 66, bar => 99 ), + [ 66, 99 ], + ); + + local @ARGS = ( [ qw/ foo foo bar foo / ] ); + is_deeply( + get_arrayref( foo => 66, bar => 99 ), + [ 66, 66, 99, 66 ], + ); + + local @ARGS = ( [ qw/ foo / ] ); + is_deeply( + get_arrayref( foo => 66, bar => 99 ), + [ 66 ], + ); + + local @ARGS = ( [ qw/ bar fool / ] ); + is_deeply( + get_arrayref( foo => 66, bar => 99 ), + [ 99, 66 ], + ); + + local @ARGS = ( [ qw/ BAR / ] ); + isnt( + exception { get_arrayref( foo => 66, bar => 99 ) }, + undef, + ); +}; + +sub get_hashref { + shift->__TO_HASHREF__( @ARGS ); +} + +subtest '__TO_HASHREF__' => sub { + + is_deeply( + get_hashref( foo => 66, bar => 99 ), + { foo => 66, bar => 99 }, + ); + + local @ARGS = ( [ qw/ foo foo bar foo / ] ); + is_deeply( + get_hashref( foo => 66, bar => 99 ), + { foo => 66, bar => 99 }, + ); + + local @ARGS = ( [ qw/ foo / ] ); + is_deeply( + get_hashref( foo => 66, bar => 99 ), + { foo => 66 }, + ); + + local @ARGS = ( [ qw/ bar fool / ] ); + is_deeply( + get_hashref( foo => 66, bar => 99 ), + { fool => 66, bar => 99 }, + ); + + local @ARGS = ( [ qw/ bar fool foo / ] ); + is_deeply( + get_hashref( foo => 66, bar => 99 ), + { foo => 66, fool => 66, bar => 99 }, + ); + + local @ARGS = ( [ qw/ BAR / ] ); + isnt( + exception { get_hashref( foo => 66, bar => 99 ) }, + undef, + ); +}; + +done_testing; From a3ef6d9e2315083cc1364f3962790c8e5abf292a Mon Sep 17 00:00:00 2001 From: Toby Inkster Date: Mon, 8 Dec 2025 17:07:06 +0000 Subject: [PATCH 2/2] fix doc example --- lib/Type/Params.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Type/Params.pm b/lib/Type/Params.pm index 43b1c81c..b2ca17e7 100644 --- a/lib/Type/Params.pm +++ b/lib/Type/Params.pm @@ -598,7 +598,7 @@ C<< __TO_LIST__ >>, C<< __TO_ARRAYREF__ >>, and C<< __TO_HASHREF__ >>. signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] ); sub add_numbers ( $arg ) { my $nums = $arg->__TO_ARRAYREF__; - return $nums[0] + $nums[1]; + return $nums->[0] + $nums->[1]; } signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] );