Handy methods for Type::Params $arg objects

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<alias>) but methods may throw an
+exception if the arrayref contains unknown field names. (See
+C<strictness> 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<named_to_list> option is ignored for signatures using positional

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;

lib/Types/Standard.pm

@@ -1355,6 +1355,10 @@ length can be given:
 
 Other customers also bought: B<< ArrayLike >> from L<Types::TypeTiny>.
 
+Notice: future versions of Types::Standard are likely to introduce
+coercions to B<ArrayRef> from B<< HasMethods['__TO_ARRAYREF__'] >> and
+from B<ArrayLike>.
+
 =item *
 
 B<< HashRef[`a] >>
@@ -1369,6 +1373,10 @@ constrain the hash values.
 
 Other customers also bought: B<< HashLike >> from L<Types::TypeTiny>.
 
+Notice: future versions of Types::Standard are likely to introduce
+coercions to B<HashRef> from B<< HasMethods['__TO_HASHREF__'] >> and
+from B<HashLike>.
+
 =item *
 
 B<< CodeRef >>
@@ -1377,6 +1385,10 @@ A value where C<< ref($value) eq "CODE" >>.
 
 Other customers also bought: B<< CodeLike >> from L<Types::TypeTiny>.
 
+Notice: future versions of Types::Standard are likely to introduce
+coercions to B<CodeRef> from B<< HasMethods['__TO_CODEREF__'] >> and
+from B<CodeLike>.
+
 =item *
 
 B<< RegexpRef >>

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 E<lt>tobyink@cpan.orgE<gt>.
+
+=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;