Skip to content

Commit 6cddeee

Browse files
tobyinktobyink
committed
Handy methods for Type::Params $arg objects
1 parent d678dca commit 6cddeee

File tree

4 files changed

+286
-0
lines changed

4 files changed

+286
-0
lines changed

‎lib/Type/Params.pm‎

Lines changed: 38 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -586,6 +586,44 @@ function as a single parameter object:
586586
say add_numbers( num1 => 2, num2 => 3 ); # says 5
587587
say add_numbers( { num1 => 2, num2 => 3 } ); # also says 5
588588
589+
Since Type::Params 2.009_000 the C<< $arg >> object has methods called
590+
C<< __TO_LIST__ >>, C<< __TO_ARRAYREF__ >>, and C<< __TO_HASHREF__ >>.
591+
592+
signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] );
593+
sub add_numbers ( $arg ) {
594+
my ( $num1, $num2 ) = $arg->__TO_LIST__;
595+
return $num1 + $num2;
596+
}
597+
598+
signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] );
599+
sub add_numbers ( $arg ) {
600+
my $nums = $arg->__TO_ARRAYREF__;
601+
return $nums[0] + $nums[1];
602+
}
603+
604+
signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] );
605+
sub add_numbers ( $arg ) {
606+
my $nums = $arg->__TO_HASHREF__;
607+
return $nums->{num1} + $nums->{num2};
608+
}
609+
610+
Each of these can be given an optional arrayref indicating which fields to
611+
return.
612+
613+
signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] );
614+
sub add_numbers ( $arg ) {
615+
my ( $num2, $num1 ) = $arg->__TO_LIST__( [ qw/ num2 num1 / ] );
616+
return $num1 + $num2;
617+
}
618+
619+
The arrayref accepts aliases (see C<alias>) but methods may throw an
620+
exception if the arrayref contains unknown field names. (See
621+
C<strictness> to control whether an exception is thrown.)
622+
623+
These methods start and end with double underscores to reduce the chance
624+
that they'll conflict with the name of a named parameter, however they are
625+
considered part of the public, supported API.
626+
589627
=head4 C<< named_to_list >> B<< ArrayRef|Bool >>
590628
591629
The C<named_to_list> option is ignored for signatures using positional

‎lib/Type/Params/Signature.pm‎

Lines changed: 82 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1083,6 +1083,8 @@ sub make_class_xs {
10831083
replace => 1,
10841084
%$attr,
10851085
);
1086+
1087+
$self->make_extra_methods;
10861088
}
10871089

10881090
sub make_class_pp {
@@ -1093,6 +1095,8 @@ sub make_class_pp {
10931095
local $@;
10941096
eval( $code ) or die( $@ );
10951097
};
1098+
1099+
$self->make_extra_methods;
10961100
}
10971101

10981102
sub make_class_pp_code {
@@ -1135,6 +1139,84 @@ sub make_class_pp_code {
11351139
return $coderef->code;
11361140
}
11371141

1142+
sub make_extra_methods {
1143+
my $self = shift;
1144+
1145+
my @parameters = @{ $self->parameters };
1146+
if ( $self->has_slurpy ) {
1147+
push @parameters, $self->slurpy;
1148+
}
1149+
1150+
my $coderef = $self->_new_code_accumulator;
1151+
$coderef->add_line( '{' );
1152+
$coderef->{indent} = "\t";
1153+
$coderef->add_line( sprintf( 'package %s;', $self->bless ) );
1154+
$coderef->add_line( 'use strict;' );
1155+
$coderef->add_line( 'no warnings;' );
1156+
1157+
$coderef->add_line( 'my @FIELDS = (' );
1158+
for my $p ( @parameters ) {
1159+
$coderef->add_line( "\t" . B::perlstring( $p->name ) . "," )
1160+
}
1161+
$coderef->add_line( ');' );
1162+
1163+
my @enum;
1164+
$coderef->add_line( 'my %FIELDS = (' );
1165+
for my $p ( @parameters ) {
1166+
$coderef->add_line( "\t" . B::perlstring( $p->name ) . " => " . B::perlstring( $p->name ) . "," );
1167+
for my $p2 ( $p->_all_aliases($self) ) {
1168+
$coderef->add_line( "\t" . B::perlstring( $p2 ) . " => " . B::perlstring( $p->name ) . "," );
1169+
}
1170+
push @enum, $p->name, $p->_all_aliases($self);
1171+
}
1172+
$coderef->add_line( ');' );
1173+
my $enum = ArrayRef[ Enum[ @enum ] ];
1174+
1175+
$coderef->add_line( 'sub __TO_LIST__ {' );
1176+
$coderef->add_line( "\t" . 'my ( $arg, $fields ) = @_;' );
1177+
$coderef->add_line( "\t" . 'return map $arg->{$_}, @FIELDS if not defined $fields;' );
1178+
if ( ( defined $self->strictness and $self->strictness eq 1 ) or not $self->has_strictness ){
1179+
$coderef->add_line( "\t" . $enum->inline_assert( '$fields' ) );
1180+
}
1181+
elsif ( $self->strictness ) {
1182+
$coderef->add_line( "\t" . sprintf( 'if ( %s ) { %s }', $self->strictness, $enum->inline_assert( '$fields' ) ) );
1183+
}
1184+
$coderef->add_line( "\t" . 'return map $arg->{$FIELDS{$_}}, @$fields;' );
1185+
$coderef->add_line( '}' );
1186+
1187+
$coderef->add_line( 'sub __TO_ARRAYREF__ {' );
1188+
$coderef->add_line( "\t" . 'my ( $arg, $fields ) = @_;' );
1189+
$coderef->add_line( "\t" . 'return [ map $arg->{$_}, @FIELDS ] if not defined $fields;' );
1190+
if ( ( defined $self->strictness and $self->strictness eq 1 ) or not $self->has_strictness ){
1191+
$coderef->add_line( "\t" . $enum->inline_assert( '$fields' ) );
1192+
}
1193+
elsif ( $self->strictness ) {
1194+
$coderef->add_line( "\t" . sprintf( 'if ( %s ) { %s }', $self->strictness, $enum->inline_assert( '$fields' ) ) );
1195+
}
1196+
$coderef->add_line( "\t" . 'return [ map $arg->{$FIELDS{$_}}, @$fields ];' );
1197+
$coderef->add_line( '}' );
1198+
1199+
$coderef->add_line( 'sub __TO_HASHREF__ {' );
1200+
$coderef->add_line( "\t" . 'my ( $arg, $fields ) = @_;' );
1201+
$coderef->add_line( "\t" . 'return +{ map { ; $_ => $arg->{$_} } @FIELDS } if not defined $fields;' );
1202+
if ( ( defined $self->strictness and $self->strictness eq 1 ) or not $self->has_strictness ){
1203+
$coderef->add_line( "\t" . $enum->inline_assert( '$fields' ) );
1204+
}
1205+
elsif ( $self->strictness ) {
1206+
$coderef->add_line( "\t" . sprintf( 'if ( %s ) { %s }', $self->strictness, $enum->inline_assert( '$fields' ) ) );
1207+
}
1208+
$coderef->add_line( "\t" . 'return +{ map { ; $_ => $arg->{$FIELDS{$_}} } @$fields };' );
1209+
$coderef->add_line( '}' );
1210+
1211+
$coderef->add_line( '1;' );
1212+
$coderef->{indent} = "";
1213+
$coderef->add_line( '}' );
1214+
1215+
my $code = $coderef->code;
1216+
local $@;
1217+
eval( $code ) or die( $@ );
1218+
}
1219+
11381220
sub return_wanted {
11391221
my $self = shift;
11401222
my $coderef = $self->coderef;

‎lib/Types/Standard.pm‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1355,6 +1355,10 @@ length can be given:
13551355
13561356
Other customers also bought: B<< ArrayLike >> from L<Types::TypeTiny>.
13571357
1358+
Notice: future versions of Types::Standard are likely to introduce
1359+
coercions to B<ArrayRef> from B<< HasMethods['__TO_ARRAYREF__'] >> and
1360+
from B<ArrayLike>.
1361+
13581362
=item *
13591363
13601364
B<< HashRef[`a] >>
@@ -1369,6 +1373,10 @@ constrain the hash values.
13691373
13701374
Other customers also bought: B<< HashLike >> from L<Types::TypeTiny>.
13711375
1376+
Notice: future versions of Types::Standard are likely to introduce
1377+
coercions to B<HashRef> from B<< HasMethods['__TO_HASHREF__'] >> and
1378+
from B<HashLike>.
1379+
13721380
=item *
13731381
13741382
B<< CodeRef >>
@@ -1377,6 +1385,10 @@ A value where C<< ref($value) eq "CODE" >>.
13771385
13781386
Other customers also bought: B<< CodeLike >> from L<Types::TypeTiny>.
13791387
1388+
Notice: future versions of Types::Standard are likely to introduce
1389+
coercions to B<CodeRef> from B<< HasMethods['__TO_CODEREF__'] >> and
1390+
from B<CodeLike>.
1391+
13801392
=item *
13811393
13821394
B<< RegexpRef >>

‎t/20-modules/Type-Params/v2-named-methods.t‎

Lines changed: 154 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,154 @@
1+
=pod
2+
3+
=encoding utf-8
4+
5+
=head1 PURPOSE
6+
7+
Named parameter tests for modern Type::Params v2 API.
8+
9+
=head1 AUTHOR
10+
11+
Toby Inkster E<lt>[email protected]E<gt>.
12+
13+
=head1 COPYRIGHT AND LICENCE
14+
15+
This software is copyright (c) 2022-2025 by Toby Inkster.
16+
17+
This is free software; you can redistribute it and/or modify it under
18+
the same terms as the Perl 5 programming language system itself.
19+
20+
=cut
21+
22+
use strict;
23+
use warnings;
24+
25+
use Test::More;
26+
use Test::Fatal;
27+
use Test::TypeTiny;
28+
29+
use Types::Common -all;
30+
31+
our @ARGS;
32+
33+
signature_for [ qw/ get_list get_arrayref get_hashref / ] => (
34+
named => [
35+
foo => Int, { alias => 'fool' },
36+
bar => Optional[Int],
37+
],
38+
);
39+
40+
sub get_list {
41+
shift->__TO_LIST__( @ARGS );
42+
}
43+
44+
subtest '__TO_LIST__' => sub {
45+
46+
is_deeply(
47+
[ get_list( foo => 66, bar => 99 ) ],
48+
[ 66, 99 ],
49+
);
50+
51+
local @ARGS = ( [ qw/ foo foo bar foo / ] );
52+
is_deeply(
53+
[ get_list( foo => 66, bar => 99 ) ],
54+
[ 66, 66, 99, 66 ],
55+
);
56+
57+
local @ARGS = ( [ qw/ foo / ] );
58+
is_deeply(
59+
[ get_list( foo => 66, bar => 99 ) ],
60+
[ 66 ],
61+
);
62+
63+
local @ARGS = ( [ qw/ bar fool / ] );
64+
is_deeply(
65+
[ get_list( foo => 66, bar => 99 ) ],
66+
[ 99, 66 ],
67+
);
68+
69+
local @ARGS = ( [ qw/ BAR / ] );
70+
isnt(
71+
exception { get_list( foo => 66, bar => 99 ) },
72+
undef,
73+
);
74+
};
75+
76+
sub get_arrayref {
77+
shift->__TO_ARRAYREF__( @ARGS );
78+
}
79+
80+
subtest '__TO_ARRAYREF__' => sub {
81+
82+
is_deeply(
83+
get_arrayref( foo => 66, bar => 99 ),
84+
[ 66, 99 ],
85+
);
86+
87+
local @ARGS = ( [ qw/ foo foo bar foo / ] );
88+
is_deeply(
89+
get_arrayref( foo => 66, bar => 99 ),
90+
[ 66, 66, 99, 66 ],
91+
);
92+
93+
local @ARGS = ( [ qw/ foo / ] );
94+
is_deeply(
95+
get_arrayref( foo => 66, bar => 99 ),
96+
[ 66 ],
97+
);
98+
99+
local @ARGS = ( [ qw/ bar fool / ] );
100+
is_deeply(
101+
get_arrayref( foo => 66, bar => 99 ),
102+
[ 99, 66 ],
103+
);
104+
105+
local @ARGS = ( [ qw/ BAR / ] );
106+
isnt(
107+
exception { get_arrayref( foo => 66, bar => 99 ) },
108+
undef,
109+
);
110+
};
111+
112+
sub get_hashref {
113+
shift->__TO_HASHREF__( @ARGS );
114+
}
115+
116+
subtest '__TO_HASHREF__' => sub {
117+
118+
is_deeply(
119+
get_hashref( foo => 66, bar => 99 ),
120+
{ foo => 66, bar => 99 },
121+
);
122+
123+
local @ARGS = ( [ qw/ foo foo bar foo / ] );
124+
is_deeply(
125+
get_hashref( foo => 66, bar => 99 ),
126+
{ foo => 66, bar => 99 },
127+
);
128+
129+
local @ARGS = ( [ qw/ foo / ] );
130+
is_deeply(
131+
get_hashref( foo => 66, bar => 99 ),
132+
{ foo => 66 },
133+
);
134+
135+
local @ARGS = ( [ qw/ bar fool / ] );
136+
is_deeply(
137+
get_hashref( foo => 66, bar => 99 ),
138+
{ fool => 66, bar => 99 },
139+
);
140+
141+
local @ARGS = ( [ qw/ bar fool foo / ] );
142+
is_deeply(
143+
get_hashref( foo => 66, bar => 99 ),
144+
{ foo => 66, fool => 66, bar => 99 },
145+
);
146+
147+
local @ARGS = ( [ qw/ BAR / ] );
148+
isnt(
149+
exception { get_hashref( foo => 66, bar => 99 ) },
150+
undef,
151+
);
152+
};
153+
154+
done_testing;

0 commit comments

Comments
 (0)